#Load required packages. (If R commander is started with an soption of #R_DEFAULT_PACKAGES="Rcmdr", other packages will not be not loaded. #library(methods, quietly=TRUE) #library(datasets, quietly=TRUE) #library(multcomp, quietly=TRUE) #library(mvtnorm, quietly=TRUE) #library(abind, quietly=TRUE) #library(aplpack, quietly=TRUE) #library(foreign, quietly=TRUE) #library(survival, quietly=TRUE) #library(cmprsk, quietly=TRUE) #library(aod, quietly=TRUE) require("datasets") #requireNamespace("car") require("methods") require("rgl") window.type <- "width=7, height=7" par.option <- 'lwd=1, las=1, family="sans", cex=1, mgp=c(3.0,1,0)' #The first parameter of mpg defines the distance between axis and axis labels. #This number is changed to 2.5 only for survival plots to avoid overlapping #with "Number at risk". par.lwd <- "lwd=1" par.cex <- "1" #assign("window.type", "width=7, height=7", envir=.GlobalEnv) #assign("par.option", 'lwd=1, las=1, family="sans", cex=1', envir=.GlobalEnv) currentFields <- NULL #A variable to send diaglog memory to Formula #currentFields$subset <- "" #Rcmdr=list(dialog.memory=TRUE) cat("\n") cat(gettextRcmdr("EZR comes with ABSOLUTELY NO WARRANTY just like R itself.", "\n")) cat(gettextRcmdr("Conditions for redistribution are also the same with R and R commander.", "\n")) cat(gettextRcmdr("Changes made from the original R commander include", "\n")) cat(gettextRcmdr("1. Replacing Rcmdr-menus.txt in //Rcmdr//etc with a file of the same name for EZR (menu file of R commander).", "\n")) cat(gettextRcmdr("2. Adding EZR.R, the main script of EZR written by Y.Kanda to //Rcmdr//etc.", "\n")) cat(gettextRcmdr("3. Replacing R-Rcmdr.mo in //Rcmdr//po//ja//LC_MESSAGES with a file of the same name for EZR (for translation in EZR).", "\n")) cat(gettextRcmdr("4. Replacing R-Rcmdr.po in //Rcmdr//po//ja//LC_MESSAGES with a file of the same name for EZR (for translation in EZR).", "\n")) cat(gettextRcmdr("5. Minimally modifying Commander.R in Rcmdr package.", "\n")) cat("\n") cat("-----------------------------------\n") cat(gettextRcmdr("Starting EZR...", "\n")) cat(" Version 1.55", "\n") cat(gettextRcmdr("Use the R commander window.", "\n")) cat("-----------------------------------\n") cat("\n") cat("-----------------------------------\n") cat(gettextRcmdr( "Please cite the following article", "\n")) cat(gettextRcmdr( "Bone Marrow Transplantation 2013:48,452-458", "\n")) cat("-----------------------------------\n") cat("\n") # for assignments to the global environment, from Rcmdr_1.9-3 #gassign <- function(x, value){ # if (!(is.valid.name(x))) stop("argument x not a valid R name") # G <- .GlobalEnv # assign(x, value, envir=G) #} ifelse2 <- function (test, yes, no) #Treat the condition of NA as FALSE. { storage.mode(test) <- "logical" # if(is.factor(yes)) yes <- as.character(yes) # if(is.factor(no)) yes <- as.character(no) nas <- is.na(test) test[nas] <- FALSE ans <- test ans[test] <- rep(yes, length.out = length(ans))[test] ans[!test] <- rep(no, length.out = length(ans))[!test] ans } ###modified from hist(), add one group below the lowest group, change default from "Sturges" to "Scott" hist2 <- function(x, breaks="scott", plot=TRUE, ...){ res <- hist(x, plot=F, breaks=breaks) if(res$breaks[1]==min(x, na.rm=TRUE)){ breaks <- c(res$breaks[1]*2-res$breaks[2], res$breaks) #add a group below the lowest group } hist(x, breaks=breaks, plot=plot, ...) } ## modified from original Hist() to use hist2() instead of hist() ## later changed to use original hist() from EZR ver 1.33 HistEZR <- function (x, scale = c("frequency", "percent", "density"), xlab = deparse(substitute(x)), ylab = scale, main = "", ...) { xlab x <- na.omit(x) scale <- match.arg(scale) if (scale == "frequency") # hist2(x, xlab = xlab, ylab = ylab, main = main, ...) res <- hist(x, xlab = xlab, ylab = ylab, main = main, ...) else if (scale == "density") # hist2(x, freq = FALSE, xlab = xlab, ylab = ylab, main = main, # ...) res <- hist(x, freq = FALSE, xlab = xlab, ylab = ylab, main = main, ...) else { n <- length(x) # hist2(x, axes = FALSE, xlab = xlab, ylab = ylab, main = main, # ...) res <- hist(x, axes = FALSE, xlab = xlab, ylab = ylab, main = main, ...) axis(1) max <- ceiling(10 * par("usr")[4]/n) at <- if (max <= 3) (0:(2 * max))/20 else (0:max)/10 axis(2, at = at * n, labels = at * 100) } breaks <- NULL for (i in 1:(length(res$breaks)-1)){ breaks[i] <- paste(res$breaks[i], "-", res$breaks[i+1], sep="") } names(res$counts) <- breaks box() abline(h = 0) invisible(NULL) return(res$counts) } nchar_ZenToHan <- function(x) { if(length(x)==1){ return(length(charToRaw(x))) } else { x2 <- NULL for(i in 1:length(x)){ x2[i] <- length(charToRaw(x[i])) } return(x2) } } ###Print dataframe with ruled lines. dataframe_print <- function(x, printrow=1) { row.number <- length(x[,1]) col.number <- length(colnames(x)) group.name.max.nchar <- max(nchar_ZenToHan(colnames(x)[1:col.number])) group.data.max.nchar <- 0 for (i in 1:(col.number)){ if(max(nchar_ZenToHan(as.character(x[,i]))) > group.data.max.nchar){ group.data.max.nchar <- max(nchar_ZenToHan(as.character(x[,i]))) } } group.nchar <- max(group.name.max.nchar, group.data.max.nchar) for (i in 1:(col.number)){ margin <- group.nchar - nchar_ZenToHan(colnames(x)[i]) colnames(x)[i] <- paste(paste(rep(" ", floor(margin/2)), collapse=""), colnames(x)[i], paste(rep(" ", ceiling(margin/2)), collapse=""), sep="") } if(printrow==1){ rownames.nchar <- max(nchar_ZenToHan(row.names(x))) line.nchar <- rownames.nchar + group.nchar * col.number line.nchar <- line.nchar + 3 * (col.number - 1) table.line <- NULL table.line[1] <- paste(rep("-", line.nchar), collapse="") table.line.1 <- paste(rep(" ", rownames.nchar), collapse="") table.line.2 <- paste(colnames(x), collapse=" | ") table.line[2] <- paste(table.line.1, table.line.2, sep=" | ") table.line[3] <- table.line[1] substring(table.line[3], rownames.nchar + 2) <- "+" for(i in 1:col.number - 1){ substring(table.line[3], rownames.nchar + 3 + (group.nchar +3 ) * (i - 1) + group.nchar + 2) <- "+" } for(i in 1:row.number){ table.line[3+i] <- paste(rep(" ", rownames.nchar - nchar_ZenToHan(row.names(x)[i])), collapse="") table.line[3+i] <- paste(row.names(x)[i], table.line[3+i], sep="") for(j in 1:col.number){ cell <- paste(rep(" ", group.nchar - nchar_ZenToHan(as.character(x[i,j]))), collapse="") cell <- paste(cell, x[i,j], sep="") table.line[3+i] <- paste(table.line[3+i], " | ", cell, sep="") } } table.line[4+row.number] <- table.line[1] } else { line.nchar <- group.nchar * col.number line.nchar <- line.nchar + 3 * (col.number - 1) table.line <- NULL table.line[1] <- paste(rep("-", line.nchar), collapse="") table.line[2] <- paste(colnames(x), collapse=" | ") table.line[3] <- table.line[1] for(i in 1:(col.number-1)){ substring(table.line[3], (group.nchar +3 ) * (i - 1) + group.nchar + 2) <- "+" } for(i in 1:row.number){ cell <- paste(rep(" ", group.nchar - nchar_ZenToHan(as.character(x[i,1]))), collapse="") table.line[3+i] <- paste(cell, x[i,1], sep="") for(j in 2:col.number){ cell <- paste(rep(" ", group.nchar - nchar_ZenToHan(as.character(x[i,j]))), collapse="") cell <- paste(cell, x[i,j], sep="") table.line[3+i] <- paste(table.line[3+i], " | ", cell, sep="") } } table.line[4+row.number] <- table.line[1] } cat(table.line, sep="\n") } ###Print twoway dataframe with ruled lines. twoway_dataframe_print <- function(x) { group.name <- x[1,3] row.number <- length(row.names(x)) col.number <- length(colnames(x)) x <- x[3:row.number,] row.number <- row.number-2 group.name.max.nchar <- max(nchar_ZenToHan(colnames(x)[1:col.number])) group.name.max.nchar <- max(group.name.max.nchar, nchar_ZenToHan(group.name)) group.data.max.nchar <- 0 for (i in 1:(col.number)){ if(max(nchar_ZenToHan(as.character(x[,i]))) > group.data.max.nchar){ group.data.max.nchar <- max(nchar_ZenToHan(as.character(x[,i]))) } } group.nchar <- max(group.name.max.nchar, group.data.max.nchar) for (i in 1:(col.number)){ margin <- group.nchar - nchar_ZenToHan(colnames(x)[i]) colnames(x)[i] <- paste(paste(rep(" ", floor(margin/2)), collapse=""), colnames(x)[i], paste(rep(" ", ceiling(margin/2)), collapse=""), sep="") } margin <- group.nchar - nchar_ZenToHan(group.name) group.name <- paste(paste(rep(" ", floor(margin/2)), collapse=""), group.name, paste(rep(" ", ceiling(margin/2)), collapse=""), sep="") rownames.nchar <- max(nchar_ZenToHan(row.names(x))) line.nchar <- group.nchar * col.number line.nchar <- line.nchar + 3 * (col.number - 1) table.line <- NULL table.line[1] <- paste(rep("-", line.nchar), collapse="") dummy.colname <- paste(rep(" ", group.nchar), collapse="") table.line[2] <- paste(paste(rep(dummy.colname, 2), collapse=" | "), paste(group.name, paste(rep(dummy.colname, col.number-4), collapse=" "), sep=" "), dummy.colname, sep=" | ") table.line[3] <- paste(colnames(x)[1], colnames(x)[2], paste(colnames(x)[3:(col.number-1)], collapse=" "), colnames(x)[col.number], sep=" | ") table.line[4] <- table.line[1] for(i in c(1, 2, col.number-1)){ substring(table.line[4], (group.nchar +3 ) * (i - 1) + group.nchar + 2) <- "+" } for(i in 1:row.number){ cell <- paste(rep(" ", group.nchar - nchar_ZenToHan(as.character(x[i,1]))), collapse="") table.line[4+i] <- paste(cell, x[i,1], sep="") for(j in 2:col.number){ cell <- paste(rep(" ", group.nchar - nchar_ZenToHan(as.character(x[i,j]))), collapse="") cell <- paste(cell, x[i,j], sep="") table.line[4+i] <- paste(table.line[4+i], " | ", cell, sep="") } } table.line[5+row.number] <- table.line[1] cat(table.line, sep="\n") } finaltable_dataframe_print <- function(x) { grouping=1 if(x[1,1]!=""){ #No grouping grouping=0 flag <- x[1,2] group.name <- "Overall" } else { #Summary with grouping flag <- x[2,2] if(flag=="Group"){ #At least one categorical variable group.name <- x[1,3] } else { #Only continuoue variables group.name <- x[1,2] } } row.number <- length(row.names(x)) col.number <- length(colnames(x)) if (grouping==1){ x <- x[3:row.number,] row.number <- row.number-2 } group.name.max.nchar <- max(nchar_ZenToHan(colnames(x)[1:col.number])) group.name.max.nchar <- max(group.name.max.nchar, nchar_ZenToHan(group.name)) group.data.max.nchar <- 0 for (i in 1:(col.number)){ if(max(nchar_ZenToHan(as.character(x[,i]))) > group.data.max.nchar){ group.data.max.nchar <- max(nchar_ZenToHan(as.character(x[,i]))) } } group.nchar <- max(group.name.max.nchar, group.data.max.nchar) for (i in 1:(col.number)){ margin <- group.nchar - nchar_ZenToHan(colnames(x)[i]) colnames(x)[i] <- paste(paste(rep(" ", floor(margin/2)), collapse=""), colnames(x)[i], paste(rep(" ", ceiling(margin/2)), collapse=""), sep="") } margin <- group.nchar - nchar_ZenToHan(group.name) group.name <- paste(paste(rep(" ", floor(margin/2)), collapse=""), group.name, paste(rep(" ", ceiling(margin/2)), collapse=""), sep="") rownames.nchar <- max(nchar_ZenToHan(row.names(x))) line.nchar <- group.nchar * col.number line.nchar <- line.nchar + 3 * (col.number - 1) table.line <- NULL table.line[1] <- paste(rep("-", line.nchar), collapse="") dummy.colname <- paste(rep(" ", group.nchar), collapse="") if (grouping==0){ table.line[2] <- "" table.line[3] <- "" table.line[4] <- "" } else { if(flag=="Group"){ #At least one categorical variable table.line[2] <- paste(paste(rep(dummy.colname, 2), collapse=" | "), paste(group.name, paste(rep(dummy.colname, col.number-4), collapse=" "), sep=" "), dummy.colname, sep=" | ") table.line[3] <- paste(colnames(x)[1], colnames(x)[2], paste(colnames(x)[3:(col.number-1)], collapse=" "), colnames(x)[col.number], sep=" | ") } else { #Only continuoue variables table.line[2] <- paste(dummy.colname, paste(group.name, paste(rep(dummy.colname, col.number-3), collapse=" "), sep=" "), dummy.colname, sep=" | ") table.line[3] <- paste(colnames(x)[1], paste(colnames(x)[2:(col.number-1)], collapse=" "), colnames(x)[col.number], sep=" | ") } table.line[4] <- table.line[1] for(i in c(1, 2, col.number-1)){ substring(table.line[4], (group.nchar +3 ) * (i - 1) + group.nchar + 2) <- "+" } } cell <- paste(rep(" ", group.nchar - nchar_ZenToHan(as.character(x[1,1]))), collapse="") table.line[5] <- paste(cell, x[1,1], sep="") for(j in 2:col.number){ margin <- group.nchar - nchar_ZenToHan(as.character(x[1,j])) cell1 <- paste(rep(" ", floor(margin/2)), collapse="") cell2 <- paste(rep(" ", ceiling(margin/2)), collapse="") cell <- paste(cell1, x[1,j], cell2, sep="") table.line[5] <- paste(table.line[5], " | ", cell, sep="") } cell <- paste(rep("-", group.nchar), collapse="") table.line[6] <- paste(rep(cell, col.number), collapse="-+-") # table.line[6] <- paste(table.line[6], paste(rep("-", 3 * (col.number)), collapse=""), sep="") for(i in 2:row.number){ cell <- paste(rep(" ", group.nchar - nchar_ZenToHan(as.character(x[i,1]))), collapse="") table.line[5+i] <- paste(cell, x[i,1], sep="") for(j in 2:col.number){ cell <- paste(rep(" ", group.nchar - nchar_ZenToHan(as.character(x[i,j]))), collapse="") cell <- paste(cell, x[i,j], sep="") table.line[5+i] <- paste(table.line[5+i], " | ", cell, sep="") } } table.line[6+row.number] <- table.line[1] if(grouping==0) table.line <- c(table.line[1], table.line[5:7], table.line[6], table.line[8:length(table.line)]) cat(table.line, sep="\n") } ###Output the results of multivariate analysis to clipboard and files. w.multi <- function (table = cox.table, filename = "clipboard", CI = 0, signif = 0, en = 1) { #Jan 2016 modified to work correctly when the number of independent covariate is only one table[, 4] <- as.numeric(table[, 4]) if (signif > 0) { table <- signif(table, digits = signif) } if (signif == 0) { table[, 1] <- floor(table[, 1] * 100 + 0.5)/100 table[, 2] <- floor(table[, 2] * 100 + 0.5)/100 table[, 3] <- floor(table[, 3] * 100 + 0.5)/100 table[, 1] <- formatC(table[, 1], format = "f", digits = 2) table[, 2] <- formatC(table[, 2], format = "f", digits = 2) table[, 3] <- formatC(table[, 3], format = "f", digits = 2) table[, 4] <- signif(as.numeric(table[, 4]), digits = 2) table[, 4] <- formatC(as.numeric(table[, 4]), format = "fg") } if(length(rownames(table))==1){ table <- rbind(table, c(" ", " ", " ", " ")) } table2 <- table if (CI == 0) { table2[, 1] <- paste(table[, 1], " (", table[, 2], "-", table[, 3], ")", sep = "") table2[, 2] <- table[, 4] table2 <- table2[, 1:2] } if(table2[2,1]==" ( - )") table2[2,1] <- " " table2 <- cbind(rownames(table), table2) colnames(table2)[1] <- ifelse(en == 1, "Factor", gettextRcmdr( "Factor")) rownames(table2) <- NULL if (en == 1 & colnames(table2)[2] == gettextRcmdr( "Hazard ratio")) colnames(table2)[2] <- "Hazard ratio" if (en == 1 & colnames(table2)[2] == gettextRcmdr( "odds ratio")) colnames(table2)[2] <- "Odds ratio" if (en == 1 & CI == 1) colnames(table2)[3:4] <- c("Lower 95%CI", "Upper 95%CI") if (CI == 0) colnames(table2)[3] <- ifelse(en == 1, "p.value", gettextRcmdr( "p.value")) if (CI == 1) colnames(table2)[5] <- ifelse(en == 1, "p.value", gettextRcmdr( "p.value")) #print(data.frame(table2), quote=FALSE, row.names=FALSE, col.names=TRUE) dataframe_print(table2, printrow=0) # print(table2) # print(paste("Write to ", filename, sep = "")) if (filename == "clipboard") { if (MacOSXP()==TRUE) { write.table(data.frame(table2), pipe("pbcopy"), sep = "\t", row.names = FALSE) } else { write.table(data.frame(table2), "clipboard", sep = "\t", row.names = FALSE) } } else { write.csv(data.frame(table2), file = as.character(filename), row.names = FALSE) } } w.multireg <- function (table = multireg.table, filename = "clipboard", CI = 0, signif = 0, en = 1) { if (signif > 0) { table <- signif(table, digits = signif) } if (signif == 0) { table[, 1] <- floor(table[, 1] * 100 + 0.5)/100 table[, 2] <- floor(table[, 2] * 100 + 0.5)/100 table[, 3] <- floor(table[, 3] * 100 + 0.5)/100 table[, 4] <- floor(table[, 4] * 100 + 0.5)/100 table[, 5] <- floor(table[, 5] * 100 + 0.5)/100 table[, 1] <- formatC(table[, 1], format = "f", digits = 2) table[, 2] <- formatC(table[, 2], format = "f", digits = 2) table[, 3] <- formatC(table[, 3], format = "f", digits = 2) table[, 4] <- formatC(table[, 4], format = "f", digits = 2) table[, 5] <- formatC(table[, 5], format = "f", digits = 2) table[, 6] <- signif(as.numeric(table[, 6]), digits = 2) table[, 6] <- formatC(as.numeric(table[, 6]), format = "fg") } table <- cbind(rownames(table), table) table[, 2] <- paste(table[, 2], " (", table[, 3], "-", table[, 4], ")", sep="") table <- table[, c(1,2,5,6,7)] if(en==1){ colnames(table) <- c("Factor", "Estimate", "Std. Error", "t value", "p.value") } else { colnames(table) <- gettextRcmdr( c("Factor", "Estimate", "Std. Error", "t value", "p.value")) } rownames(table) <- NULL # print(data.frame(table), quote=FALSE, row.names=FALSE, col.names=TRUE) dataframe_print(table, printrow=0) # print(paste("Write to ", filename, sep = "")) if (filename == "clipboard") { if (MacOSXP()==TRUE) { write.table(data.frame(table), pipe("pbcopy"), sep = "\t", row.names = FALSE) } else { write.table(data.frame(table), "clipboard", sep = "\t", row.names = FALSE) } } else { write.csv(data.frame(table), file = as.character(filename), row.names = FALSE) } } ###Output two-way table to clipboard and files. w.twoway <- function (table = Fisher.summary.table, filename = "clipboard", en = 1) { table <- as.matrix(table) rows <- length(table[, 1]) columns <- length(table) Factor <- substring(row.names(table), 1, regexpr("=", row.names(table)) - 1) Group <- substring(row.names(table), regexpr("=", row.names(table)) + 1) for (i in 1:(rows - 1)) { j <- 1 while (Factor[i] == Factor[i + j]) { Factor[i + j] <- "" j <- j + 1 if ((i + j) > rows) break } } StratifyFactor <- substring(colnames(table), 1, regexpr("=", colnames(table)) - 1) StratifyGroup <- substring(colnames(table), regexpr("=", colnames(table)) + 1) colnames(table) <- StratifyGroup table <- cbind(Factor, Group, table) # rownames(table) <- NULL colnames(table)[length(colnames(table))] <- ifelse(en == 1, "p.value", gettextRcmdr("p.value")) if (en == 0) colnames(table) <- gettextRcmdr( colnames(table)) # print(data.frame(table), quote=F, row.names = FALSE, col.names = FALSE) ncol <- length(colnames(table)) row1 <- colnames(table) row1 <- matrix(row1, ncol=ncol) table <- rbind(row1, table) row0 <- rep(" ", ncol) row0[3] <- StratifyFactor[1] table <- rbind(row0, table) twoway_dataframe_print(table) # print(paste("Write to ", filename, sep = "")) if (filename == "clipboard") { if (MacOSXP()==TRUE) { write.table(data.frame(table), pipe("pbcopy"), sep = "\t", row.names = FALSE, col.names = FALSE) } else { write.table(data.frame(table), "clipboard", sep = "\t", row.names = FALSE, col.names = FALSE) } } else { write.table(data.frame(table), file = as.character(filename), sep = ",", row.names = FALSE, col.names = FALSE) } } ###Output the results of t-test to clipboard and files. w.ttest <- function (table = summary.ttest, filename = "clipboard", en = 1) { rows <- length(table[, 1]) columns <- length(table) Factor <- substring(row.names(table), 1, regexpr("=", row.names(table)) - 1) Group <- substring(row.names(table), regexpr("=", row.names(table)) + 1) for (i in 1:(rows - 1)) { j <- 1 while (Factor[i] == Factor[i + j]) { Factor[i + j] <- "" j <- j + 1 if ((i + j) > rows) break } } table[, 3] <- as.numeric(as.character(data.frame(table)[, 3])) table <- signif(data.frame(table), digits = 3) table[, 3] <- ifelse(is.na(table[, 3]), "", table[, 3]) table[, 1] <- paste(table[, 1], " +- ", table[, 2], sep = "") table <- table[, c(1, 3)] colnames(table)[1] <- "mean +- SD" table <- cbind(Factor, Group, table) rownames(table) <- NULL colnames(table)[4] <- ifelse(en == 1, "p.value", gettextRcmdr( "p.value")) if (en == 0) colnames(table)[1:3] <- gettextRcmdr( c("Factor", "Group", "mean +- SD")) # print(data.frame(table), quote=FALSE, row.names=FALSE) dataframe_print(table, printrow=0) # print(table) # print(paste("Write to ", filename, sep = "")) if (filename == "clipboard") { if (MacOSXP()==TRUE) { write.table(data.frame(table), pipe("pbcopy"), sep = "\t", row.names = FALSE) } else { write.table(data.frame(table), "clipboard", sep = "\t", row.names = FALSE) } } else { write.csv(data.frame(table), file = as.character(filename), row.names = FALSE) } } w.survival <- function (table = km.summary.table, filename = "clipboard", en = 1) { rows <- length(table[, 1]) columns <- length(table) Factor <- substring(row.names(table), 1, regexpr("=", row.names(table)) - 1) Group <- substring(row.names(table), regexpr("=", row.names(table)) + 1) for (i in 1:(rows - 1)) { j <- 1 while (Factor[i] == Factor[i + j]) { Factor[i + j] <- "" j <- j + 1 if ((i + j) > rows) break } } if (colnames(table)[2] == gettextRcmdr( "median survival")) { table[, 2] <- paste(table[, 2], " (", table[, 3], ")", sep = "") table <- table[, c(1, 2, 4)] if (en == 1) { colnames(table)[1:3] <- c("n", "median survival", "p.value") } else { colnames(table)[1:3] <- gettextRcmdr( c("n", "median survival", "p.value")) } } if (colnames(table)[2] == gettextRcmdr( "survival rate")) { table[, 2] <- paste(table[, 2], " ", table[, 3], sep = "") table[, 4] <- paste(table[, 4], " (", table[, 5], ")", sep = "") table <- table[, c(1, 2, 4, 6)] if (en == 1) { colnames(table)[1:4] <- c("n", "survival rate", "median survival", "p.value") } else { colnames(table)[1:4] <- gettextRcmdr( c("n", "survival rate", "median survival", "p.value")) } } table <- cbind(Factor, Group, table) rownames(table) <- NULL if (en == 0) colnames(table)[1:2] <- gettextRcmdr( c("Factor", "Group")) # print(table, quote=FALSE, row.names=FALSE, col.names=TRUE) dataframe_print(table, printrow=0) # print(table) # print(paste("Write to ", filename, sep = "")) if (filename == "clipboard") { if (MacOSXP()==TRUE) { write.table(data.frame(table), pipe("pbcopy"), sep = "\t", row.names = FALSE) } else { write.table(data.frame(table), "clipboard", sep = "\t", row.names = FALSE) } } else { write.csv(data.frame(table), file = as.character(filename), row.names = FALSE) } } w.ci <- function (table = ci.summary.table, filename = "clipboard", en = 1) { rows <- length(table[, 1]) columns <- length(table) Group_Factor <- substring(row.names(table), 1, regexpr(",", row.names(table))-1) Factor <- substring(Group_Factor, 1, regexpr("=", Group_Factor) - 1) Group <- substring(Group_Factor, regexpr("=", Group_Factor)+1) Event <- substring(row.names(table), regexpr(",", row.names(table)) + 2, nchar(row.names(table))) for (i in 1:(rows - 1)) { j <- 1 while (Factor[i] == Factor[i + j]) { Factor[i + j] <- "" j <- j + 1 if ((i + j) > rows) break } } if (colnames(table)[2] == gettextRcmdr( "incidence")) { table[, 2] <- paste(table[, 2], " ", table[, 3], sep = "") table <- table[, c(1, 2, 4, 5)] if (en == 1) { colnames(table)[1:4] <- c("n", "incidence", "median time", "p.value") } else { colnames(table)[1:4] <- gettextRcmdr( c("n", "incidence", "median time", "p.value")) } } else { if (en == 1) { colnames(table)[1:3] <- c("n", "median time", "p.value") } else { colnames(table)[1:3] <- gettextRcmdr( c("n", "median time", "p.value")) } } table <- cbind(Factor, Group, Event, table) rownames(table) <- NULL if (en == 0) colnames(table)[1:3] <- gettextRcmdr( c("Factor", "Group", "Event")) # print(table, quote=FALSE, row.names=FALSE, col.names=TRUE) dataframe_print(table, printrow=0) # print(table) # print(paste("Write to ", filename, sep = "")) if (filename == "clipboard") { if (MacOSXP()==TRUE) { write.table(data.frame(table), pipe("pbcopy"), sep = "\t", row.names = FALSE) } else { write.table(data.frame(table), "clipboard", sep = "\t", row.names = FALSE) } } else { write.csv(data.frame(table), file = as.character(filename), row.names = FALSE) } } ChrToFactor <- function(dataset){ for (i in 1:length(dataset)){ if (is.character(dataset[,i])==TRUE){ dataset[,i] <- factor(dataset[,i]) cat(paste(colnames(dataset[i]), " ", gettextRcmdr("was converted to a factor."), "\n", sep="")) } } return(dataset) } .funincrisk <- function(cdat, conf.level) { ### from epiR package, required for epi.tests() N. <- 1 - ((1 - conf.level)/2) a <- cdat[, 1] n <- cdat[, 2] b <- n - a p <- a/n a. <- ifelse(a == 0, a + 1, a) b. <- ifelse(b == 0, b + 1, b) low <- a./(a. + (b. + 1) * (1/qf(1 - N., 2 * a., 2 * b. + 2))) up <- (a. + 1)/(a. + 1 + b./(1/qf(1 - N., 2 * b., 2 * a. + 2))) low <- ifelse(a == 0, 0, low) up <- ifelse(a == n, 1, up) rval <- data.frame(est = p, lower = low, upper = up) rval } epi.tests <- function (dat, conf.level = 0.95, verbose = FALSE) { ### from epiR package 0.9-45 N. <- 1 - ((1 - conf.level)/2) z <- qnorm(N., mean = 0, sd = 1) .funincrisk <- function(cdat, conf.level) { N. <- 1 - ((1 - conf.level)/2) a <- cdat[, 1] n <- cdat[, 2] b <- n - a p <- a/n a. <- ifelse(a == 0, a + 1, a) b. <- ifelse(b == 0, b + 1, b) low <- a./(a. + (b. + 1) * (1/qf(1 - N., 2 * a., 2 * b. + 2))) up <- (a. + 1)/(a. + 1 + b./(1/qf(1 - N., 2 * b., 2 * a. + 2))) low <- ifelse(a == 0, 0, low) up <- ifelse(a == n, 1, up) rval <- data.frame(est = p, lower = low, upper = up) rval } a <- dat[1] b <- dat[3] c <- dat[2] d <- dat[4] M1 <- a + c M0 <- b + d N1 <- a + b N0 <- c + d total <- a + b + c + d tdat <- as.matrix(cbind(M1, total)) trval <- .funincrisk(tdat, conf.level) tp <- trval$est tp.low <- trval$lower tp.up <- trval$upper tprev <- data.frame(est = tp, lower = tp.low, upper = tp.up) tdat <- as.matrix(cbind(N1, total)) trval <- .funincrisk(tdat, conf.level) ap <- trval$est ap.low <- trval$lower ap.up <- trval$upper aprev <- data.frame(est = ap, lower = ap.low, upper = ap.up) tdat <- as.matrix(cbind(a, M1)) trval <- .funincrisk(tdat, conf.level) se <- trval$est se.low <- trval$lower se.up <- trval$upper sensitivity <- data.frame(est = se, lower = se.low, upper = se.up) tdat <- as.matrix(cbind(d, M0)) trval <- .funincrisk(tdat, conf.level) sp <- trval$est sp.low <- trval$lower sp.up <- trval$upper specificity <- data.frame(est = sp, lower = sp.low, upper = sp.up) tdat <- as.matrix(cbind(a, N1)) trval <- .funincrisk(tdat, conf.level) ppv <- trval$est ppv.low <- trval$lower ppv.up <- trval$upper pv.positive <- data.frame(est = ppv, lower = ppv.low, upper = ppv.up) tdat <- as.matrix(cbind(d, N0)) trval <- .funincrisk(tdat, conf.level) npv <- trval$est npv.low <- trval$lower npv.up <- trval$upper pv.negative <- data.frame(est = npv, lower = npv.low, upper = npv.up) lrpos <- (a/M1)/(1 - (d/M0)) lrpos.low <- exp(log(lrpos) - z * sqrt((1 - se)/(M1 * se) + (sp)/(M0 * (1 - sp)))) lrpos.up <- exp(log(lrpos) + z * sqrt((1 - se)/(M1 * se) + (sp)/(M0 * (1 - sp)))) lr.positive <- data.frame(est = lrpos, lower = lrpos.low, upper = lrpos.up) lrneg <- (1 - (a/M1))/(d/M0) lrneg.low <- exp(log(lrneg) - z * sqrt((se)/(M1 * (1 - se)) + (1 - sp)/(M0 * (sp)))) lrneg.up <- exp(log(lrneg) + z * sqrt((se)/(M1 * (1 - se)) + (1 - sp)/(M0 * (sp)))) lr.negative <- data.frame(est = lrneg, lower = lrneg.low, upper = lrneg.up) tdat <- as.matrix(cbind((a + d), total)) trval <- .funincrisk(tdat, conf.level) da <- trval$est da.low <- trval$lower da.up <- trval$upper diag.acc <- data.frame(est = da, lower = da.low, upper = da.up) dOR.p <- (a * d)/(b * c) lndOR <- log(dOR.p) lndOR.var <- 1/a + 1/b + 1/c + 1/d lndOR.se <- sqrt(1/a + 1/b + 1/c + 1/d) lndOR.l <- lndOR - (z * lndOR.se) lndOR.u <- lndOR + (z * lndOR.se) dOR.se <- exp(lndOR.se) dOR.low <- exp(lndOR.l) dOR.up <- exp(lndOR.u) diag.or <- data.frame(est = dOR.p, lower = dOR.low, upper = dOR.up) ndx <- 1/(se - (1 - sp)) ndx.1 <- 1/(se.low - (1 - sp.low)) ndx.2 <- 1/(se.up - (1 - sp.up)) ndx.low <- min(ndx.1, ndx.2) ndx.up <- max(ndx.1, ndx.2) nnd <- data.frame(est = ndx, lower = ndx.low, upper = ndx.up) c.p <- se - (1 - sp) c.1 <- se.low - (1 - sp.low) c.2 <- se.up - (1 - sp.up) c.low <- min(c.1, c.2) c.up <- max(c.1, c.2) youden <- data.frame(est = c.p, lower = c.low, upper = c.up) if (verbose == TRUE) { rval <- list(aprev = aprev, tprev = tprev, se = sensitivity, sp = specificity, diag.acc = diag.acc, diag.or = diag.or, nnd = nnd, youden = youden, ppv = pv.positive, npv = pv.negative, plr = lr.positive, nlr = lr.negative) return(rval) } if (verbose == FALSE) { r1 <- c(a, b, N1) r2 <- c(c, d, N0) r3 <- c(M1, M0, M0 + M1) tab <- as.data.frame(rbind(r1, r2, r3)) colnames(tab) <- gettextRcmdr(c("Disease positive", "Disease negative", "Total")) rownames(tab) <- gettextRcmdr(c("Test positive", "Test negative", "Total")) tab <- format.data.frame(tab, digits = 3, justify = "right") print(tab) cat("\n", gettextRcmdr("Point estimates and"), conf.level * 100, "%", gettextRcmdr("CIs:")) cat("\n---------------------------------------------------------\n") res.table <- c(aprev$est, aprev$lower, aprev$upper) res.table <- rbind(res.table, c(tprev$est, tprev$lower, tprev$upper)) res.table <- rbind(res.table, c(sensitivity$est, sensitivity$lower, sensitivity$upper)) res.table <- rbind(res.table, c(specificity$est, specificity$lower, specificity$upper)) res.table <- rbind(res.table, c(pv.positive$est, pv.positive$lower, pv.positive$upper)) res.table <- rbind(res.table, c(pv.negative$est, pv.negative$lower, pv.negative$upper)) res.table <- rbind(res.table, c(diag.acc$est, diag.acc$lower, diag.acc$upper)) res.table <- rbind(res.table, c(lr.positive$est, lr.positive$lower, lr.positive$upper)) res.table <- rbind(res.table, c(lr.negative$est, lr.negative$lower, lr.negative$upper)) res.table <- round(res.table, digits=3) colnames(res.table) <- gettextRcmdr( c("Estimation", "Lower CI", "Upper CI")) rownames(res.table) <- gettextRcmdr( c("Apparent prevalence", "True prevalence", "Sensitivity", "Specificity", "Positive predictive value", "Negative predictive value", "Diagnstic accuracy", "Likelihood ratio of a positive test", "Likelihood ratio of a negative test")) print(res.table) cat("---------------------------------------------------------") cat("\n") } } epi.kappa <- function (dat, conf.level = 0.95) { ### from epiR package 0.9-27. In this version, mcNemar test is pweformed. a <- dat[1] b <- dat[3] c <- dat[2] d <- dat[4] N. <- 1 - ((1 - conf.level)/2) z <- qnorm(N., mean = 0, sd = 1) lower <- "lower" upper <- "upper" n <- a + b + c + d pO <- (a + d)/n pE.pos <- ((a + b) * (a + c))/n^2 pE.neg <- ((c + d) * (b + d))/n^2 pE <- pE.pos + pE.neg kappa <- (pO - pE)/(1 - pE) se.kappa <- sqrt((pO * (1 - pO))/(n * (1 - pE)^2)) kappa.low <- kappa - (z * se.kappa) kappa.up <- kappa + (z * se.kappa) mcnemar <- (b - c)^2/(b + c) p.chi2 <- 1 - pchisq(mcnemar, df = 1) kappa <- as.data.frame(cbind(kappa, kappa.low, kappa.up)) names(kappa) <- c("est", lower, upper) mcnemar <- as.data.frame(cbind(test.statistic = mcnemar, df = 1, p.value = p.chi2)) rval <- list(kappa = kappa, mcnemar = mcnemar) return(rval) } dot.plot <- function(x, y, accu=0, stp=0, log.flag=FALSE, simple=FALSE, symmetrical=TRUE, ...) { #modified from http://aoki2.si.gunma-u.ac.jp/R/dot_plot.html OK <- complete.cases(x, y) x <- x[OK] x <- as.factor(x) y <- y[OK] x.name <- unique(x) if (is.factor(x)) { x <- as.integer(x) } if (log.flag == TRUE) { y0 <- y y <- log10(y) } if (accu == 0) { accu <- diff(range(y))/100 } if(stp == 0) { stp <- (diff(range(x))+1)/100 } y <- round(y/accu)*accu x1 <- unique(x) for (i in seq(along=x1)) { freq <- table(y[x==x1[i]]) for (j in seq(along=freq)) { if (freq[j] >= 2) { offset <- ifelse(symmetrical, (freq[j]-1)/2*stp, 0) for (k in seq(along=y)) { if (abs(y[k]-as.numeric(names(freq)[j])) < 1e-10 && abs(x[k]-x1[i]) < 1e-10) { freq[j] <- freq[j]-1 x[k] <- x[k]-offset+freq[j]*stp } } } } } if (log.flag) { plot(x, y, type="n", xaxt="n", yaxt="n", xlim=c(min(x)-0.5, max(x)+0.5), ...) options(warn=-1) points(x, y, ...) options(warn=0) y0 <- floor(log10(y0)) log.min <- min(y0) y2 <- 1:10*10^log.min n <- max(y0)-log.min y1 <- rep(y2, n+1)*10^rep(0:n, each=10) if (simple) { y2 <- y1[abs(log10(y1)-round(log10(y1))) < 1e-6] axis(2, at=log10(y1), labels=FALSE) axis(2, at=log10(y2), labels=y2) } else { axis(2, at=log10(y1), labels=y1) } } else { plot(x, y, xaxt="n", xlim=c(min(x)-0.5, max(x)+0.5), ...) } if (length(x.name)>1) { axis(1, at=x1, labels=as.character(x.name)) } } OrderedPlot <- function(y, group=NULL, type="line", xlab="", ylab="Value", ylog=FALSE, lowlim=NULL, uplim=NULL, decreasing=FALSE){ #For waterfall plot, ordered chart if (is.null(group)){ cc <- complete.cases(y) } else { cc <- complete.cases(y, group) } y <- y[cc] if (is.null(lowlim)) lowlim <- min(y) if (type=="box" & ylog==FALSE & lowlim>0) lowlim <- 0 if (is.null(uplim)) uplim=max(y) ylim=c(lowlim, uplim) ylog <- ifelse(ylog==TRUE, "y", "") group <- group[cc] if (!is.null(group)){ group <- factor(group) levels <- levels(group) } if (type=="box"){ if(is.null(group)){ Order <- order(y, decreasing=decreasing) names.arg=NULL barplot(y[Order], names.arg=names.arg, axis.lty=1, col="grey", ylim=ylim, log=ylog, axisnames=TRUE) } else { Order <- order(y, decreasing=decreasing) names.arg=NULL barplot(y[Order], names.arg=names.arg, axis.lty=1, col=as.integer(group[Order])+1, ylim=ylim, log=ylog, axisnames=TRUE) if (decreasing==FALSE){ legend("topleft", levels, col=1, pt.bg=2:(length(levels)+1), pch=22, box.lty=0) } else { legend("topright", levels, col=1, pt.bg=2:(length(levels)+1), pch=22, box.lty=0) } } } if (type=="line"){ if(is.null(group)){ Order <- order(y, decreasing=decreasing) plot(x=seq(from=0, to=1, length.out=length(y)), y=y[Order], xaxp=c(0,1,10), type="l", ylim=ylim, log=ylog, xlab=xlab, ylab=ylab) } else{ j <- 1 for (i in levels){ Order <- order(y[group==i], decreasing=decreasing) axt <- "s" if (j>1) {par(new=T);axt <- "n"; xlab <- ""; ylab <- ""} plot(x=seq(from=0, to=1, length.out=length(y[group==i])), y=y[group==i][Order], xaxp=c(0,1,10), type="l", ylim=ylim, log=ylog, xlab=xlab, ylab=ylab, xaxt=axt, yaxt=axt, lty=j) j <- j+1 } if (decreasing==FALSE){ legend("topleft", levels, col=1, lty=1:32, lwd=1, box.lty=0) } else { legend("topright", levels, col=1, lty=1:32, lwd=1, box.lty=0) } } } } SwimmerPlot <- function(State, EndState, Group=NULL, Order=NULL, Censored=NULL, Gray=0, Event=NULL, TimeEvent=NULL, Dataset) { Library("swimplot") Library("ggplot2") SampleNumber <- length(Dataset[,1]) Dataset$id_temp <- 1:SampleNumber if(is.null(Group)) Group <- FALSE if (is.null(State) | is.null(EndState)){ return() } StateNumber <- length(State) DataframeForSimplePlot <- reshape(Dataset, varying=State, v.names="StateChange", timevar="State", direction="long") DataframeForSimplePlot$EndStateChange <- NA for(i in 1:StateNumber){ for(j in 1:SampleNumber){ line <- SampleNumber*(i-1)+j # command <- paste("DataframeForSimplePlot$EndStateChange[line] <- with(DataframeForSimplePlot, EndState", i, "[line])", sep="") command <- paste("DataframeForSimplePlot$EndStateChange[line] <- DataframeForSimplePlot$", EndState[i], "[line]", sep="") eval(parse(text=command)) } } MainPlot <- swimmer_plot(df=DataframeForSimplePlot, id="id", end="EndStateChange", name_fill="StateChange", stratify=Group, id_order=Order, col="black", alpha=0.75, width=.85) if(Gray==1){ MainPlot <- MainPlot + scale_fill_grey() } EventNumber <- length(Event) if(EventNumber>=1){ DataframeForEventPlot <- reshape(Dataset, varying=Event, v.names="EventName", timevar="EventNumber", direction="long") DataframeForEventPlot$TimeEvent <- NA for(i in 1:EventNumber){ for(j in 1:SampleNumber){ line <- SampleNumber*(i-1)+j # command <- paste("DataframeForEventPlot$TimeForEvent[line] <- with(DataframeForEventPlot, TimeEvent", i, "[line])", sep="") command <- paste("DataframeForEventPlot$TimeForEvent[line] <- DataframeForEventPlot$", TimeEvent[i], "[line]", sep="") eval(parse(text=command)) } } } if (EventNumber==0){ FinalPlot <- MainPlot } else { FinalPlot <- MainPlot + swimmer_points(df_points=DataframeForEventPlot, id="id", time="TimeForEvent", name_shape="EventName", size=2.5, fill="white", col="black") } if (!is.null(Censored)){ command <- paste("with(Dataset, pmax(", paste(EndState, collapse=', '), ", na.rm=TRUE))", sep="") Dataset$StartArrow <- eval(parse(text=command)) arrow_length <- max(Dataset$StartArrow, na.rm=TRUE)/20 Dataset$Censored <- ifelse(Dataset$Censored==0, NA, Dataset$Censored) FinalPlot <- FinalPlot + swimmer_arrows(df_arrows=Dataset, id="id_temp", arrow_start="StartArrow", arrow_positions=c(0,arrow_length), length=0.05, cont="Censored", type="open", size=1) } FinalPlot } BarplotFor3Factors <- function(First, Second, Third, prop=0, col=0, data){ dataset <- eval(parse(text=data)) legend <- eval(parse(text=paste("levels(factor(", data, "$", First, "))", sep=""))) groups <- eval(parse(text=paste("levels(factor(", data, "$", Second, "))", sep=""))) levels <- eval(parse(text=paste("levels(factor(", data, "$", Third, "))", sep=""))) num <- length(levels) colors <- gray(2:(length(legend)+1) / (length(legend)+2)) if (col==1) colors <- 2:(1+length(legend)) res <- eval(parse(text=paste("xtabs(~", First, "+", Second, ", data=dataset, subset=", Third, "=='", levels[1], "')", sep=""))) if (prop==0){ barplot.table <- res }else{ barplot.table <- prop.table(res,2) } dummy <- rep(0, length(barplot.table[,1])) for (i in 2:num){ res <- eval(parse(text=paste("xtabs(~", First, "+", Second, ", data=dataset, subset=", Third, "=='", levels[i], "')", sep=""))) if (prop==0){ barplot.table <- cbind(barplot.table, " "=dummy, res) }else{ barplot.table <- cbind(barplot.table, " "=dummy, prop.table(res,2)) } } mar <- par("mar") mar[1] <- mar[1] + 2.5 mar[3] <- mar[3] + 1.5 par(mar=mar) opar <- par(mar = mar) on.exit(par(opar)) if(prop==1){ legend.y <- 1.2 } else { max.height <- 0 for(i in 1:length(barplot.table[1,])) { if (sum(barplot.table[,i]) > max.height) {max.height <- sum(barplot.table[,i])} } legend.y <- max.height * 1.2 } (bplot <- barplot(barplot.table, beside=FALSE, xlab=NULL, ylab="Frequency", col=colors, legend=legend, args.legend=list(y=legend.y, horiz=TRUE, title=First, box.lty=0), axis.lty=1)) at <- NULL for (i in 1:num){ at <- c(at, (bplot[(length(groups)+1)*(i-1)+1]+bplot[(length(groups)+1)*(i-1)+length(groups)])/2) } center <- (bplot[1] + bplot[length(bplot)])/2 axis(1, at = center, labels = Second, line = 2, tick = FALSE, las=0) # axis(1, at = at, labels = rep(Third, length(levels)), line = 4, tick = FALSE, las=0) axis(1, at = center, labels = Third, line = 4, tick = FALSE, las=0) axis(1, at = at, labels = levels, line = 5, tick = FALSE, las=0) } nrisk <- function (x, times = pretty(x$time)) { #Function to count number at risk in KM plot. Modified from survplot package to be applied for single group. # stopifnot(class(x) == "survfit") if (!is.null(x$strata)){ ns <- length(x$strata) idx <- rep.int(1:ns, x$strata) if(is.matrix(x$n.risk)==TRUE){ str.n.risk <- split(x$n.risk[,length(x$n.risk[1,])], idx) #for ci } else { str.n.risk <- split(x$n.risk, idx) # for km } # change made according to the change in survival function # str.n.risk <- split(x$n.risk, idx) str.times <- split(x$time, idx) m <- sapply(times, function(y) { sapply(1:ns, function(i) { w <- which(str.times[[i]] >= y)[1] ifelse(is.na(w), 0, str.n.risk[[i]][w]) }) }) rownames(m) <- names(x$strata) colnames(m) <- times } else { if(is.matrix(x$n.risk)==TRUE){ str.n.risk <- x$n.risk[,length(x$n.risk[1,])] #for ci } else { str.n.risk <- x$n.risk # for km } # change made according to the change in survival function # str.n.risk <- x$n.risk str.times <- x$time m <- sapply(times, function(y) { w <- which(str.times >= y)[1] ifelse(is.na(w), 0, str.n.risk[w]) }) # rownames(m) <- names(x$strata) # colnames(m) <- times } m } prop.conf <- function( r, n, conf){ #modified from http://aoki2.si.gunma-u.ac.jp/R/p-conf.html p <- r/n alpha <- 1-conf/100 if (p == 0) { pl <- 0 # pu <- 1-alpha^(1/n) #Until Ver 1.42, this function showed one-sided confidence intervals when the success rate is 0 or 1. pu <- 1-(alpha/2)^(1/n) #From Ver 1.50, this function was changed to show two-sided confidence intervals to keep consitency with binom.test() and other softwares. } else if (p == 1) { # pl <- alpha^(1/n) pl <- (alpha/2)^(1/n) pu <- 1 } else { nu1 <- 2*(n-r+1) nu2 <- 2*r Fv <- qf(alpha/2, nu1, nu2, lower.tail=FALSE) pl <- nu2/(nu1*Fv+nu2) nu1 <- 2*(r+1) nu2 <- 2*(n-r) Fv <- qf(alpha/2, nu1, nu2, lower.tail=FALSE) pu <- nu1*Fv/(nu1*Fv+nu2) } print(paste(gettextRcmdr("Probability :"), " ", round(p,3), sep=""), quote=F) print(paste(conf, gettextRcmdr("% confidence interval :"), " ", round(pl,3), " - ", round(pu,3), sep=""), quote=F) } prop.diff.conf <- function(r1, n1, r2, n2, conf) { alpha <- 1-conf/100 p1 <- r1/n1 p2 <- r2/n2 D <- p1-p2 SE <- sqrt(p1*(1-p1)/n1 + p2*(1-p2)/n2) pl <- D-qnorm(1-alpha/2)*SE pu <- D+qnorm(1-alpha/2)*SE print(paste(gettextRcmdr("Difference :"), " ", round(D,3), sep=""), quote=F) print(paste(conf, gettextRcmdr("% confidence interval :"), " ", round(pl,3), " - ", round(pu,3), sep=""), quote=F) } prop.ratio.conf <- function(r1, n1, r2, n2, conf) { alpha <- 1-conf/100 p1 <- r1/n1 p2 <- r2/n2 RR<- p1/p2 SE <- sqrt((n1-r1)/r1/n1+(n2-r2)/r2/n2) pl <- exp(log(RR)-qnorm(1-alpha/2)*SE) pu <- exp(log(RR)+qnorm(1-alpha/2)*SE) print(paste(gettextRcmdr("Ratio : "), round(RR,3), sep=""), quote=F) print(paste(conf, gettextRcmdr("% confidence interval : "), round(pl,3), " - ", round(pu,3), sep=""), quote=F) } error.bar <- function(x, y, upper, lower=upper, length=0.1,...){ if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper)) stop(gettextRcmdr("vectors must be same length")) arrows(x,y+upper, x, y-lower, angle=90, code=3, length=length, ...) } StatMedplotMeans <- function(response, factor1, factor2, error.bars = c("se", "sd", "conf.int", "none"), level=0.95, xlab=deparse(substitute(factor1)), ylab=paste("mean of", deparse(substitute(response))), legend.lab=deparse(substitute(factor2)), main="Plot of Means", pch=1:n.levs.2, lty=1:n.levs.2, lwd=1:n.levs.2, col=palette(), yrange=NULL){ if (!is.numeric(response)) stop(gettextRcmdr("Argument response must be numeric.")) xlab # force evaluation ylab legend.lab error.bars <- match.arg(error.bars) if (missing(factor2)){ if (!is.factor(factor1)) stop(gettextRcmdr("Argument factor1 must be a factor.")) valid <- complete.cases(factor1, response) factor1 <- factor1[valid] response <- response[valid] means <- tapply(response, factor1, mean) sds <- tapply(response, factor1, sd) ns <- tapply(response, factor1, length) if (error.bars == "se") sds <- sds/sqrt(ns) if (error.bars == "conf.int") sds <- qt((1 - level)/2, df=ns - 1, lower.tail=FALSE) * sds/sqrt(ns) sds[is.na(sds)] <- 0 if (is.null(yrange)){ yrange <- if (error.bars != "none") c( min(means - sds, na.rm=TRUE), max(means + sds, na.rm=TRUE)) else range(means, na.rm=TRUE) } levs <- levels(factor1) n.levs <- length(levs) plot(c(1, n.levs), yrange, type="n", xlab=xlab, ylab=ylab, axes=FALSE, main=main) points(1:n.levs, means, type="b", pch=16, cex=2) box() axis(2) axis(1, at=1:n.levs, labels=levs) if (error.bars != "none") arrows(1:n.levs, means - sds, 1:n.levs, means + sds, angle=90, lty=2, code=3, length=0.125) } else { if (!(is.factor(factor1) | is.factor(factor2))) stop(gettextRcmdr("Arguments factor1 and factor2 must be factors.")) valid <- complete.cases(factor1, factor2, response) factor1 <- factor1[valid] factor2 <- factor2[valid] response <- response[valid] means <- tapply(response, list(factor1, factor2), mean) sds <- tapply(response, list(factor1, factor2), sd) ns <- tapply(response, list(factor1, factor2), length) if (error.bars == "se") sds <- sds/sqrt(ns) if (error.bars == "conf.int") sds <- qt((1 - level)/2, df=ns - 1, lower.tail=FALSE) * sds/sqrt(ns) sds[is.na(sds)] <- 0 if (is.null(yrange)){ yrange <- if (error.bars != "none") c( min(means - sds, na.rm=TRUE), max(means + sds, na.rm=TRUE)) else range(means, na.rm=TRUE) } levs.1 <- levels(factor1) levs.2 <- levels(factor2) n.levs.1 <- length(levs.1) n.levs.2 <- length(levs.2) if (length(pch) == 1) pch <- rep(pch, n.levs.2) if (length(col) == 1) col <- rep(col, n.levs.2) if (length(lty) == 1) lty <- rep(lty, n.levs.2) if (length(lwd) == 1) lwd <- rep(lwd, n.levs.2) if (n.levs.2 > length(col)) stop(sprintf(gettextRcmdr("Number of groups for factor2, %d, exceeds number of distinct colours, %d."), n.levs.2, length(col))) plot(c(1, n.levs.1 * 1.2), yrange, type="n", xlab=xlab, ylab=ylab, axes=FALSE, main=main) box() axis(2) axis(1, at=1:n.levs.1, labels=levs.1) for (i in 1:n.levs.2){ points(1:n.levs.1, means[, i], type="b", pch=pch[i], cex=2, col=col[i], lty=lty[i], lwd=lwd[i]) if (error.bars != "none") arrows(1:n.levs.1, means[, i] - sds[, i], 1:n.levs.1, means[, i] + sds[, i], angle=90, code=3, col=col[i], lty=lty[i], lwd=lwd[i], length=0.125) } # x.posn <- n.levs.1 * 1.4 x.posn <- n.levs.1 y.posn <- sum(c(0.1, 0.9) * par("usr")[c(3,4)]) # text(x.posn, y.posn, legend.lab, adj=c(0, -.5)) # legend(x.posn, y.posn, levs.2, pch=pch, col=col, lty=lty) legend("topright", levs.2, pch=pch, col=col, lty=lty, lwd=lwd, title=legend.lab, box.lty=0) } invisible(NULL) } skewness.kurtosis <- function(x){ x <- x[!is.na(x)] # skewness <- signif(mean((x-mean(x))^3)/(sd(x)^3), digits=3) #sample skewness # kurtosis <- signif(mean((x-mean(x))^4)/(sd(x)^4)-3, digits=3) #sample kurtosis n <- length(x) m <- mean(x) sd <- sd(x) skewness <- signif({n/(n-1)/(n-2)} * sum((x-m)^3) / sd^3, digits=3) #population skewness, same as kurt(), skew() in excel kurtosis <- signif({n*(n+1)/(n-1)/(n-2)/(n-3)} * sum((x-m)^4) / sd^4 - 3*(n-1)^2/(n-2)/(n-3), digits=3) #population kurtosis res <- data.frame(c(gettextRcmdr("Skewness (0 for normal distribution)"), gettextRcmdr("Kurtosis (0 for normal distribution)")), c(skewness, kurtosis)) rownames(res) <- c("", " ") colnames(res) <- c("", " ") return(res) } Cochran.Q.test <- function(x) { #http://aoki2.si.gunma-u.ac.jp/R/Cochran-Q-test.html data.name <- deparse(substitute(x)) method <- "Cochran's Q test" x <- subset(x, complete.cases(x)) k <- ncol(x) g <- colSums(x) l <- rowSums(x) Q <- ((k-1)*(k*sum(g^2)-sum(g)^2))/(k*sum(l)-sum(l^2)) df <- k-1 p <- pchisq(Q, df, lower.tail=FALSE) names(Q) <- "X-squared" names(df) <- "df" return(structure(list(statistic=Q, parameter=df, p.value=p, method=method, data.name=data.name), class="htest")) } pairwise.prop2.test <- function (x, n, p.adjust.method = p.adjust.methods, test.function=prop.test, ...){ #modified from http://aoki2.si.gunma-u.ac.jp/R/p_multi_comp2.html #to extend for fisher.test() and to show the results with group names. p.adjust.method <- match.arg(p.adjust.method) METHOD <- deparse(substitute(test.function)) DNAME <- deparse(substitute(x)) if (is.matrix(x)) { if (ncol(x) < 2) stop("'x' must have at least 2 columns") } else if (is.vector(x) && is.vector(n)) x <- cbind(x, n-x) else stop("'x' must be a matrix, or 'x', and 'n' must be a vector") if (nrow(x) < 2) stop("too few groups") group.names <- rownames(x) compare.levels <- function(i, j) { test.function(x[c(i, j),], ...)$p.value } level.names <- names(x) if (is.null(level.names)) level.names <- group.names[seq_along(1:nrow(x))] PVAL <- pairwise.table(compare.levels, level.names, p.adjust.method) ans <- list(method = METHOD, data.name = DNAME, p.value = PVAL, p.adjust.method = p.adjust.method) class(ans) <- "pairwise.htest" ans } pairwise.pairedt.test <- function (response, group=NULL, data.name, p.adjust.method = p.adjust.methods){ #modified from http://aoki2.si.gunma-u.ac.jp/R/p_multi_comp2.html if(!is.null(group)){ group <- factor(group) contrasts(group) <- "contr.Sum" } p.adjust.method <- match.arg(p.adjust.method) method <- "Paired t-test" time.names <- colnames(response) n <- length(time.names) p <- NULL n.comp <- 0 for (i in 2:n){ for (j in 1:(n-1)){ if (j < i){ pairwise.response <- response[, time.names==time.names[i] | time.names==time.names[j]] if(!is.null(group)){ AnovaModel <- lm(pairwise.response ~ group, na.action=na.omit) time <- factor(colnames(pairwise.response)) time <- data.frame(Time = time) res <- Anova(AnovaModel, idata=time, idesign=~Time, type="III") res <- capture.output(summary(res, multivariate=FALSE)) }else{ AnovaModel <- lm(pairwise.response ~ 1, na.action=na.omit) time <- factor(colnames(pairwise.response)) time <- data.frame(Time = time) res <- Anova(AnovaModel, idata=time, idesign=~Time, type="III") res <- capture.output(summary(res, multivariate=FALSE)) } ###The results of Anova() cannot be obtained by summry(), and thus should be extracted from the output text. l <- 0 ###Looking for a row that stat with "Time" for(k in 1:length(res)){ if(substr(res[k],1,4)=="Time"){ res <- res[k] break } } res <- strsplit(res, split=" ") l <- 0 ###Extract p value for(k in 1:length(res[[1]])){ if(res[[1]][k]!="")l <- l+1 if(l==7){ p[j] <- res[[1]][k] break } } n.comp <- n.comp+1 } else { p[j] <- NA } } if (i==2){ pairwise.table <- p } else { pairwise.table <- rbind(pairwise.table, p) } } pairwise.table <- matrix (p.adjust(pairwise.table, method=p.adjust.method, n.comp), n-1) rownames(pairwise.table) <- time.names[2:n] colnames(pairwise.table) <- time.names[1:n-1] ans <- list(method=method, data.name=data.name, p.value = pairwise.table, p.adjust.method = p.adjust.method) class(ans) <- "pairwise.htest" ans } pairwise.kruskal.test <- function (response, group, data.name, p.adjust.method = p.adjust.methods){ #modified from http://aoki2.si.gunma-u.ac.jp/R/p_multi_comp2.html p.adjust.method <- match.arg(p.adjust.method) method <- "Mann-Whitney U test" group.names <- levels(factor(group)) n <- length(group.names) p <- NULL n.comp <- 0 for (i in 2:n){ for (j in 1:(n-1)){ if (j < i){ pairwise.response <- response[group==group.names[i] | group==group.names[j]] pairwise.group <- group[group==group.names[i] | group==group.names[j]] res <- wilcox.test(pairwise.response ~ factor(pairwise.group)) p[j] <- signif(res$p.value,digits=3) n.comp <- n.comp+1 } else { p[j] <- NA } } if (i==2){ pairwise.table <- p } else { pairwise.table <- rbind(pairwise.table, p) } } pairwise.table <- matrix (p.adjust(pairwise.table, method=p.adjust.method, n.comp), n-1) rownames(pairwise.table) <- group.names[2:n] colnames(pairwise.table) <- group.names[1:n-1] ans <- list(method=method, data.name=data.name, p.value = pairwise.table, p.adjust.method = p.adjust.method) class(ans) <- "pairwise.htest" ans } pairwise.friedman.test <- function (response, data.name, p.adjust.method = p.adjust.methods){ #modified from http://aoki2.si.gunma-u.ac.jp/R/p_multi_comp2.html p.adjust.method <- match.arg(p.adjust.method) method <- "Wilcoxon signed rank test" time.names <- colnames(response) n <- length(time.names) p <- NULL n.comp <- 0 for (i in 2:n){ for (j in 1:(n-1)){ if (j < i){ pairwise.response1 <- response[, time.names==time.names[i]] pairwise.response2 <- response[, time.names==time.names[j]] res <- wilcox.test(pairwise.response1, pairwise.response2, alternative='two.sided', paired=TRUE) p[j] <- signif(res$p.value, digits=3) n.comp <- n.comp+1 } else { p[j] <- NA } } if (i==2){ pairwise.table <- p } else { pairwise.table <- rbind(pairwise.table, p) } } pairwise.table <- matrix (p.adjust(pairwise.table, method=p.adjust.method, n.comp), n-1) rownames(pairwise.table) <- time.names[2:n] colnames(pairwise.table) <- time.names[1:n-1] ans <- list(method=method, data.name=data.name, p.value = pairwise.table, p.adjust.method = p.adjust.method) class(ans) <- "pairwise.htest" ans } pairwise.logrank.test <- function (time, event, group, strata=NULL, data.name, p.adjust.method = p.adjust.methods, rho=0){ #modified from http://aoki2.si.gunma-u.ac.jp/R/p_multi_comp2.html p.adjust.method <- match.arg(p.adjust.method) if (rho==0) method <- "logrank test" else method <- "Generalized Wilcoxon test" group.names <- levels(factor(group)) n <- length(group.names) p <- NULL n.comp <- 0 for (i in 2:n){ for (j in 1:(n-1)){ if (j < i){ pairwise.time <- time[group==group.names[i] | group==group.names[j]] pairwise.event <- event[group==group.names[i] | group==group.names[j]] pairwise.group <- group[group==group.names[i] | group==group.names[j]] if(is.null(strata)){ res <- survdiff(Surv(pairwise.time, pairwise.event==1)~pairwise.group, rho=rho) } else { pairwise.strata <- strata[group==group.names[i] | group==group.names[j]] res <- survdiff(Surv(pairwise.time, pairwise.event==1)~pairwise.group+strata(pairwise.strata), rho=rho) } p[j] <- signif(pchisq(c(res$chisq), df=1, lower.tail=FALSE),digits=3) n.comp <- n.comp+1 } else { p[j] <- NA } } if (i==2){ pairwise.table <- p } else { pairwise.table <- rbind(pairwise.table, p) } } pairwise.table <- matrix (p.adjust(pairwise.table, method=p.adjust.method, n.comp), n-1) rownames(pairwise.table) <- group.names[2:n] colnames(pairwise.table) <- group.names[1:n-1] ans <- list(method=method, data.name=data.name, p.value = pairwise.table, p.adjust.method = p.adjust.method) class(ans) <- "pairwise.htest" ans } pairwise.gray.test <- function (time, event, group, data.name, p.adjust.method = p.adjust.methods, endpoint=1){ #modified from http://aoki2.si.gunma-u.ac.jp/R/p_multi_comp2.html p.adjust.method <- match.arg(p.adjust.method) method <- "Gray test" group.names <- levels(factor(group)) n <- length(group.names) p <- NULL n.comp <- 0 for (i in 2:n){ for (j in 1:(n-1)){ if (j < i){ pairwise.time <- time[group==group.names[i] | group==group.names[j]] pairwise.event <- event[group==group.names[i] | group==group.names[j]] pairwise.group <- group[group==group.names[i] | group==group.names[j]] res <- cuminc(pairwise.time, pairwise.event, pairwise.group, cencode=0, na.action=na.omit) p[j] <- signif(res$Tests[endpoint, 2],digits=3) n.comp <- n.comp+1 } else { p[j] <- NA } } if (i==2){ pairwise.table <- p } else { pairwise.table <- rbind(pairwise.table, p) } } pairwise.table <- matrix (p.adjust(pairwise.table, method=p.adjust.method, n.comp), n-1) rownames(pairwise.table) <- group.names[2:n] colnames(pairwise.table) <- group.names[1:n-1] ans <- list(method=method, data.name=data.name, p.value = pairwise.table, p.adjust.method = p.adjust.method) class(ans) <- "pairwise.htest" ans } Steel.Dwass <- function(data, group){ #modified from http://aoki2.si.gunma-u.ac.jp/R/Steel-Dwass.html OK <- complete.cases(data, group) data <- data[OK] group <- factor(group[OK]) n.i <- table(group) ng <- length(n.i) t <- combn(ng, 2, function(ij) { i <- ij[1] j <- ij[2] r <- rank(c(data[group == levels(factor(group))[i]], data[group == levels(factor(group))[j]])) R <- sum(r[1:n.i[i]]) N <- n.i[i]+n.i[j] E <- n.i[i]*(N+1)/2 V <- n.i[i]*n.i[j]/(N*(N-1))*(sum(r^2)-N*(N+1)^2/4) return(abs(R-E)/sqrt(V)) }) p <- ptukey(t*sqrt(2), ng, Inf, lower.tail=FALSE) result <- cbind(t, p) rownames(result) <- combn(levels(factor(group)), 2, paste, collapse=":") return(result) } Steel <- function(data, group) { #modified from http://aoki2.si.gunma-u.ac.jp/R/Steel.html get.rho <- function(ni) { k <- length(ni) rho <- outer(ni, ni, function(x, y) { sqrt(x/(x+ni[1])*y/(y+ni[1])) }) diag(rho) <- 0 sum(rho[-1, -1])/(k-2)/(k-1) } OK <- complete.cases(data, group) data <- data[OK] group <- factor(group[OK]) ni <- table(group) a <- length(ni) control <- data[group == levels(factor(group))[1]] n1 <- length(control) t <- numeric(a) rho <- ifelse(sum(n1 == ni) == a, 0.5, get.rho(ni)) p.value <- numeric(a) for (i in 2:a) { r <- rank(c(control, data[group == levels(factor(group))[i]])) R <- sum(r[1:n1]) N <- n1+ni[i] E <- n1*(N+1)/2 V <- n1*ni[i]/N/(N-1)*(sum(r^2)-N*(N+1)^2/4) t[i] <- abs(R-E)/sqrt(V) p.value[i] <- pdunnett(t[i], a, df=0, r=rho) } result <- cbind(t, rho, p.value)[-1,] rownames(result) <- paste(levels(factor(group))[1], levels(factor(group))[2:a], sep=":") return(result) } pdunnett <- function(x, a, df, r) { # Used in Steel(). Originated from Dunnet() corr <- diag(a-1) corr[lower.tri(corr)] <- r 1-pmvt(lower=-x, upper=x, delta=numeric(a-1), df=df, corr=corr, abseps=0.0001) } RemoveOutlier <- function(x, return){ i <- 0 repeat{ x1 <- x[!is.na(x)] n <- length(x1) if(max(x1)-mean(x1)>=mean(x1)-min(x1)){ p.value <- n*pt(sqrt((n-2)/((n-1)^2/((max(x1)-mean(x1))/sd(x1))^2/n-1)), n-2, lower.tail=FALSE) if(p.value < 0.05) { cat(gettextRcmdr("Identify data"), " ", max(x1), " ", gettextRcmdr("as an outlier. (Smirnov-Grubbs p-value="), p.value, ")\n", sep="") x[x==max(x1)] <- NA i <- i + 1 } } else { p.value <- n*pt(sqrt((n-2)/((n-1)^2/((mean(x1)-min(x1))/sd(x1))^2/n-1)), n-2, lower.tail=FALSE) if(p.value < 0.05) { cat(gettextRcmdr("Identify data"), min(x1), gettextRcmdr("as an outlier. (Smirnov-Grubbs p-value="), p.value, ")\n", sep="") x[x==min(x1)] <- NA i <- i + 1 } } if(p.value >= 0.05) break } if (i==0) cat(gettextRcmdr("No outliers were identified."), "\n") if (return==1) return(x) } summary.table.twoway <- function(object, ..., table, res){ p.value <- signif(res$p.value, digits=3) summary.table <- data.frame(cbind(table, p.value)) groups1 <- length(levels(factor(data.frame(table)[,1]))) groups2 <- length(levels(factor(data.frame(table)[,2]))) for (i in 1:groups1){ rownames(summary.table)[i] <- paste(names(data.frame(table))[1], "=", levels(factor(data.frame(table)[,1]))[i], sep="") if (i >=2) summary.table$p.value[i] <- "" } for (i in 1:groups2){ colnames(summary.table)[i] <- paste(names(data.frame(table))[2], "=", levels(factor(data.frame(table)[,2]))[i], sep="") } if(res$method=="Fisher's Exact Test for Count Data"){ colnames(summary.table)[length(summary.table)] <- "Fisher.p.value" } else { colnames(summary.table)[length(summary.table)] <- "Chisq.p.value" } return(summary.table) } summary.table.MH <- function(object, ..., table, res){ MH.p.value <- signif(res$p.value, digits=3) summary.table <- data.frame(cbind(table, MH.p.value)) groups1 <- length(levels(factor(data.frame(table)[,1]))) groups2 <- length(levels(factor(data.frame(table)[,2]))) for (i in 1:groups1){ rownames(summary.table)[i] <- paste(names(data.frame(table))[1], "=", levels(factor(data.frame(table)[,1]))[i], sep="") if (i >=2) summary.table$MH.p.value[i] <- "" } for (i in 1:groups2){ colnames(summary.table)[i] <- paste(names(data.frame(table))[2], "=", levels(factor(data.frame(table)[,2]))[i], sep="") } return(summary.table) } summary.km <- function (object, ..., survfit, survdiff=NULL, time=0){ km <- survfit km.table <- summary(survfit) if (is.null(survdiff)){ p.value <- NULL }else{ p.value <- signif(pchisq(c(survdiff$chisq), df=length(survdiff$n)-1, lower.tail=FALSE),digits=3) } if (is.null(survdiff)){ groups <- 1 samples <- km.table$table[1] medians <- km.table$table[7] med.ci <- paste(km.table$table[8], "-", km.table$table[9], sep="") km$strata[1] <- samples }else{ group.names <- row.names(km.table$table) groups <- length(group.names) samples <- km.table$table[,1] medians <- km.table$table[,7] med.ci <- paste(km.table$table[,8], "-", km.table$table[,9], sep="") } surv <- NULL surv.ci <- NULL if (time > 0){ # show survival rate at time start <- 1 for(i in 1:groups){ numbers <- km$strata[i] stop <- start + numbers - 1 timetoevent <- km$time[start:stop] if (max(timetoevent, na.rm=TRUE) >= time){ point <- max((1:length(timetoevent))[timetoevent<=time], na.rm=TRUE) surv[i] <- formatC(km$surv[start+point-1], format="f", digits=3) surv.ci[i] <- paste("(", formatC(km$lower[start+point-1], format="f", digits=3), "-", formatC(km$upper[start+point-1], format="f", digits=3), ")", sep="") }else{ surv[i] <- NA surv.ci[i] <- NA } start <- stop + 1 } } if(groups==1){ surv.table <- data.frame(t(c(samples, probability=surv, CI=surv.ci, median=medians, medianCI=med.ci))) # colnames(surv.table)[1:3] <- c("n", "median survival", "95% CI") # if(length(surv.table)==5){ # colnames(surv.table)[1:5] <- c("n", "survival rate", "95% CI", "median survival", "95% CI") # } }else{ for(i in 2:groups){ p.value[i] <- "" } if(!is.null(surv.ci)){ surv.table <- data.frame(n=samples, probability=surv, CI=surv.ci, median=medians, medianCI=med.ci, p.value) # colnames(surv.table)[1:3] <- c("n", "median survival", "95% CI") # if(length(surv.table)==5){ # colnames(surv.table)[1:5] <- c("n", "survival rate", "95% CI", "median survival", "95% CI") # } }else{ surv.table <- data.frame(n=samples, median=medians, medianCI=med.ci, p.value) # colnames(surv.table)[1:3] <- c("n", "median survival", "95% CI") } } colnames(surv.table)[1:3] <- c("n", "median survival", "95% CI") if(length(surv.table)>=5){ colnames(surv.table)[1:5] <- c("n", "survival rate", "95% CI", "median survival", "95% CI") } colnames(surv.table) <- gettextRcmdr( colnames(surv.table)) return(surv.table) } summary.ci <- function (object, ..., ci, res, event=1, time=0){ ci.table <- summary(ci) if(is.null(ci$strata)){ ngroups <- 1 p.value <- NULL } else { groups <- levels(ci.table$strata) ngroups <- length(groups) p.value <- signif(res$Tests[event, 2],digits=3) } if (is.null(ci$surv)) ci$surv <- 1 - ci$prev nevents <- length(ci$surv[1, ]) - 1 # changes made according to survival package upgrade to include no event group # nevents <- length(ci$surv[1,]) # samples <- ci.table$table[as.numeric(substring(row.names(ci.table$table), # nchar(row.names(ci.table$table)), nchar(row.names(ci.table$table)))) == event, 1] samples <- ci.table$table[substring(row.names(ci.table$table), nchar(row.names(ci.table$table)), nchar(row.names(ci.table$table))) == event, 1] #delete as.numeric according to the change in survival 3.1-8 samples <- samples[!is.na(samples)] # changes made according to survival package upgrade to change the row.names # samples <- ci.table$table[as.numeric(substring(row.names(ci.table$table),1,1))==event,1] medians <- get.median.ci(ci=ci, res=res, event=event) # changes made according to survival package upgrade not to show medians # medians <- ci.table$table[as.numeric(substring(row.names(ci.table$table),1,1))==event,5] surv <- NULL surv.ci <- NULL if (time > 0){ # show survival rate at time for(i in 1:ngroups){ survival <- timepoints(res, time)$est[ngroups*(event-1)+i] hazard <- log(survival) se <- sqrt(timepoints(res, time)$var[ngroups*(event-1)+i]) lower <- survival^exp(-qnorm(0.975)*se/(survival*hazard)) #log-log # lower <- survival*exp(-qnorm(0.975)*se/(survival)) #log if(is.nan(lower)) lower<-0 if(is.na(lower)==FALSE & lower>1) lower<-1 upper <- survival^exp(qnorm(0.975)*se/(survival*hazard)) #log-lgo # upper <- survival*exp(qnorm(0.975)*se/(survival)) #log if(is.nan(upper)) upper<-0 if(is.na(upper)==FALSE & upper>1) upper<-1 surv[i] <- formatC(survival, format="f", digits=3) surv.ci[i] <- paste("(", formatC(lower, format="f", digits=3), "-", formatC(upper, format="f", digits=3), ")", sep="") } } if(ngroups==1){ if(!is.null(surv)){ surv.table <- data.frame(n=samples, incidence=surv, CI=surv.ci, median=medians) colnames(surv.table)[3] <- "95% CI" }else{ surv.table <- data.frame(n=samples, median=medians) colnames(surv.table)[2] <- "median time" } }else{ p.value[2:ngroups] <- "" if(!is.null(surv)){ surv.table <- data.frame(n=samples, incidence=surv, CI=surv.ci, median=medians, p.value) colnames(surv.table)[3] <- "95% CI" colnames(surv.table)[4] <- "median time" }else{ surv.table <- data.frame(n=samples, median=medians, p.value) colnames(surv.table)[2] <- "median time" } } colnames(surv.table) <- gettextRcmdr( colnames(surv.table)) return(surv.table) } get.median.ci <- function (x, ..., ci, res, event=1) { ngroups <- length(ci$n) group.names <- names(ci$strata) if (is.null(ci$surv)) ci$surv <- 1 - ci$prev nevents <- length(ci$surv[1, ]) - 1 #event column with no event left here in the new survival package #event column with no event should be deleted zerocolumn <- NA for (i in 1:nevents) { zerocolumn[i] <- ifelse(sum(1-ci$surv[,i])==0, 0, 1) } # ci$surv <- ci$surv[,zerocolumn==1] nevents <- sum(zerocolumn) median.table <- NULL median.CIL.table <- NULL median.CIH.table <- NULL i <- event # for (i in 1:nevents) { for (j in 1:ngroups) { time <- res[[ngroups * (i - 1) + j]]$time est <- res[[ngroups * (i - 1) + j]]$est var <- res[[ngroups * (i - 1) + j]]$var se <- sqrt(var) hazard <- log(est) lower <- est^exp(-qnorm(0.975) * se/(est * hazard)) upper <- est^exp(qnorm(0.975) * se/(est * hazard)) lower <- ifelse(is.nan(lower), 0, lower) lower <- ifelse(!is.na(lower) & lower>1, 1, lower) upper <- ifelse(is.nan(upper), 0, upper) upper <- ifelse(!is.na(upper) & upper>1, 1, upper) median <- NA if(max(est)>=0.5){ median.est <- min(which(est>=0.5)) median <- time[median.est] if (0.5 %in% est & max(est)>0.5) { #if the curve is flat at 0.5 until last observation, #the median is the first point when the curve reaches 0.5 #same as the median survival in survival package median.est.flat <- which(est==0.5) if(length(median.est.flat)>1){ median <- (time[min(median.est.flat)]+time[max(median.est.flat)])/2 } } } median.CIL <- NA if(max(upper)>=0.5){ median.lower <- min(which(upper>=0.5)) median.CIL <- time[median.lower] if (0.5 %in% upper & max(upper)>0.5) { median.lower.flat <- which(upper==0.5) if(length(median.lower.flat)>1){ median.CIL <- (time[min(median.lower.flat)]+time[max(median.lower.flat)])/2 } } } median.CIH <- NA if(max(lower)>=0.5){ median.upper <- min(which(lower>=0.5)) median.CIH <- time[median.upper] if (0.5 %in% lower & max(lower)>0.5) { median.upper.flat <- which(lower==0.5) if(length(median.upper.flat)>1){ median.CIH <- (time[min(median.upper.flat)]+time[max(median.upper.flat)])/2 } } } # cat(paste(as.character(i), as.character(j), as.character(median), as.character(median.CIL), as.character(median.CIH), "\n", sep=", ")) median.table <- c(median.table, median) median.CIL.table <- c(median.CIL.table, median.CIL) median.CIH.table <- c(median.CIH.table, median.CIH) #if(medifan.flag==1) { } #when the curve is flat at 50% until the end of last observation, #the median value is set at the time when the curve first reached 50% #same as the median survival of survival package. } # } median.table <- paste(median.table, " (", median.CIL.table, "-", median.CIH.table, ")", sep="") return(median.table) } rmean.table <- function(x=km, tau=NULL, plot = 0){ Library("survRM2") if (is.null(tau)) tau <- "NULL" formula <- as.character(x$call)[2] dataset <- as.character(x$call)[3] time <- substr(formula, 6, regexpr(",", formula)-1) if(substr(time, 1, 1)=="("){ time <- substring(time, 2, regexpr("/", time)-1) } status <- substr(formula, regexpr(",", formula)+2, regexpr("==", formula)-2) arm <- substr(formula, regexpr("~", formula)+2, nchar(formula)) dataset <- paste(dataset, "[complete.cases(", dataset, "$", time, ", ", dataset, "$", status, ", ", dataset, "$", arm, "),]", sep="") if (length(x$call)==6){ subset <- as.character(x$call[4]) if (regexpr('\"', subset)==TRUE){ subset <- paste(substring(subset, 1, regexpr('\"', subset)-1), "'", substring(subset, regexpr('\"', subset)+1, nchar(subset)), sep="") subset <- paste(substring(subset, 1, regexpr('\"', subset)-1), "'", substring(subset, regexpr('\"', subset)+1, nchar(subset)), sep="") } dataset <- paste("subset(", dataset, ", subset=", subset, ")", sep="") } if(eval(parse(text=paste("length(levels(droplevels(as.factor(", dataset, "$", arm, "))))", sep="")))==2){ #survRM2 can be used only when the number of arms is 2 (group names should be 0 and 1) groups <- eval(parse(text=paste("levels(droplevels(as.factor(", dataset, "$", arm, ")))", sep=""))) group <- ifelse(eval(parse(text=paste("droplevels(as.factor(", dataset, "$", arm, "))", sep="")))==groups[1], 0, 1) cat(paste("arm 0 = ", groups[1], "\n", sep="")) cat(paste("arm 1 = ", groups[2], "\n", sep="")) command <- paste("res <- rmst2(", dataset, "$", time, ", ", dataset, "$", status, ", group, tau=", tau, ", alpha=0.05)", sep="") eval(parse(text=command)) print(res) if(plot==1)plot(res) } else { #The "common" option uses the maximum time for all curves in the object #as a common upper limit for the auc calculation in survival package, #but this is different from the default of survRM2 package, which uses #the minimum of the largest observed event time on each of the two groups. #In this function, the definition of survRM2 package was applied, because #the package was written by Mr. Hajime Uno, who published several articles #with regard to restricted mean survival. if (tau=="NULL"){ res <- summary(x) LatestEventTime <- NULL for (i in 1:length(x$strata)){ LatestEventTime[i] <- max(res$time[res$strata==names(x$strata[i])]) } tau <- min(LatestEventTime) } res <- summary(x, rmean=tau) if(!is.matrix(res$table)){ rmean.table <- res$table[c(1,5,6)] } else { rmean.table <- data.frame(res$table[,c(1,5,6)]) n <- res$table[,1] #numbers rmean <- res$table[,5] #means se <- res$table[,6] #standard errors CIH <- signif(rmean + qnorm(c(0.025), mean=0, sd=1, lower.tail=F)*se, digits=3) CIL <- signif(rmean - qnorm(c(0.025), mean=0, sd=1, lower.tail=F)*se, digits=3) CI <- paste(CIL, " - ", CIH, sep="") rmean.table <- cbind(rmean.table, rmean.CI=c(paste("(", CI, ")", sep=""))) colnames(rmean.table) <- c("n", "rmean", "se", "95% CI") } print(paste("Restricted mean survival until ", tau, sep="")) return(rmean.table) } } rmean.table.adjusted <- function(x=coxmodel, tau=NULL){ Library("survRM2") formula <- as.character(x$call)[2] dataset <- as.character(x$call)[3] time <- substr(formula, 6, regexpr(",", formula)-1) status <- substr(formula, regexpr(",", formula)+2, regexpr("==", formula)-2) arm <- substr(formula, regexpr("strata", formula)+7, nchar(formula)-1) if(eval(parse(text=paste("length(levels(droplevels(as.factor(", dataset, "$", arm, "))))", sep="")))==2){ #survRM2 can be used only when the number of arms is 2 (group names should be 0 and 1) groups <- eval(parse(text=paste("levels(droplevels(as.factor(", dataset, "$", arm, ")))", sep=""))) group <- ifelse(eval(parse(text=paste("droplevels(as.factor(", dataset, "$", arm, "))", sep="")))==groups[1], 0, 1) cat(paste("arm 0 = ", groups[1], "\n", sep="")) cat(paste("arm 1 = ", groups[2], "\n", sep="")) } else { cat("The number of arms must be 2.\n") return() } covariate <- substr(formula, regexpr("~", formula)+2, regexpr("strata", formula)-4) covariates <- strsplit(covariate, split=" + ", fixed=TRUE) covariate <- paste("cbind(", covariates[[1]][1], "=", dataset, "$", covariates[[1]][1], sep="") if (length(covariates[[1]])>1){ for (i in 2:length(covariates[[1]])){ covariate <- paste(covariate, ", ", covariates[[1]][i], "=", dataset, "$", covariates[[1]][i], sep="") } } covariate <- paste(covariate, ")", sep="") if(substr(time, 1, 1)=="("){ # command <- paste("rmst2((", dataset, "$", substr(time, 2, nchar(time)-1), "), ", dataset, "$", status, ", ", dataset, "$", arm, ", tau=", tau, ", covariates=", covariate, ", alpha=0.05)", sep="") command <- paste("rmst2((", dataset, "$", substr(time, 2, nchar(time)-1), "), ", dataset, "$", status, ", group, tau=", tau, ", covariates=", covariate, ", alpha=0.05)", sep="") } else { # command <- paste("rmst2(", dataset, "$", substr(time, 2, nchar(time)-1), ", ", dataset, "$", status, ", ", dataset, "$", arm, ", tau=", tau, ", covariates=", covariate, ", alpha=0.05)", sep="") command <- paste("rmst2(", dataset, "$", substr(time, 2, nchar(time)-1), ", ", dataset, "$", status, ", group, tau=", tau, ", covariates=", covariate, ", alpha=0.05)", sep="") } eval(parse(text=command)) } print.ci.summary <- function (x, ..., ci) { ngroups <- length(ci$n) group.names <- names(ci$strata) nevents <- length(ci$states) - 1 start <- 1 for (i in 1:ngroups) { if (ngroups == 1) { stop <- start + length(ci$time) - 1 } else { stop <- start + ci$strata[i] - 1 } ci.summary.table <- data.frame(time = ci$time[start:stop], n.risk = ci$n.risk[start:stop], n.event = rowSums(ci$n.event[start:stop,])) for (j in 1:nevents){ ci95 <- paste("(", formatC(ci$lower[start:stop, j+1], format = "f", digits = 3), "-", formatC(ci$upper[start:stop, j+1], format = "f", digits = 3), ")", sep = "") ci.summary.table <- cbind(ci.summary.table, ci$pstate[start:stop, j+1], ci95) colnames(ci.summary.table)[2 + j * 2] <- paste("incidence-", j, sep = "") colnames(ci.summary.table)[3 + j * 2] <- paste("95% CI-", j, sep = "") } cat("\t\t", names(ci$strata[i]), "\n") print(ci.summary.table[ci.summary.table$n.event>0,]) cat("\n") start <- stop + 1 } } StatMedTableOne <- function(){ Library("tableone") defaults <- list(group=NULL, cat=NULL, cont=NULL, contnonnormal=NULL, exact="auto", range="TRUE", explain="FALSE", smd="FALSE", output="clipboard", language="1", subset = "") dialog.values <- getDialog("StatMedTableOne", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Summary table of sample characteristics")) groupBox <- variableListBox(top, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=10, initialSelection=varPosn(dialog.values$group, "all")) variableFrame <- tkframe(top) categoryBox <- variableListBox(variableFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Categorical variables"), listHeight=10, initialSelection=varPosn(dialog.values$cat, "all")) contBox <- variableListBox(variableFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Continuous variables (normal distribution)"), listHeight=10, initialSelection=varPosn(dialog.values$cont, "all")) contnonnormalBox <- variableListBox(variableFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Continuous variables (non-normal distribution)"), listHeight=10, initialSelection=varPosn(dialog.values$contnonnormal, "all")) optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="exact", buttons=c("chisq", "fisher", "auto"), values=c("chisq", "exact", "auto"), initialValue=dialog.values$exact, labels=gettextRcmdr(c("Chi-square test with continuity correction", "Fisher's exact test", "Automatic selection")), title=gettextRcmdr("Test for categorical variables")) radioButtons(optionsFrame, name="range", buttons=c("MinMax", "IQR"), values=c("TRUE", "FALSE"), initialValue=dialog.values$range, labels=gettextRcmdr(c("Minimum and maximum values", "Interquartile ranges")), title=gettextRcmdr("Range for non-normal categorical variables")) radioButtons(optionsFrame, name="explain", buttons=c("No", "Yes"), values=c("FALSE", "TRUE"), initialValue=dialog.values$explain, labels=gettextRcmdr(c("No", "Yes")), title=gettextRcmdr("Show explantation for continuous variables")) radioButtons(optionsFrame, name="smd", buttons=c("No", "Yes"), values=c("FALSE", "TRUE"), initialValue=dialog.values$smd, labels=gettextRcmdr(c("No", "Yes")), title=gettextRcmdr("Show standardized differences")) options2Frame <- tkframe(top) radioButtons(options2Frame, name="output", buttons=c("Clipboard", "CSVfile"), values=c("clipboard", "CSVfile"), initialValue=dialog.values$output, labels=gettextRcmdr(c("Clipboard", "CSV file")), title=gettextRcmdr("Output destination")) radioButtons(options2Frame, name="language", buttons=c("Eng", "Local"), values=c("1", "0"), initialValue=dialog.values$language, labels=gettextRcmdr(c("English", "Local")), title=gettextRcmdr("Language")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Summary table of sample characteristics"), "#####", sep="")) group <- getSelection(groupBox) cat <- getSelection(categoryBox) cont <- getSelection(contBox) contnonnormal <- getSelection(contnonnormalBox) exact <- tclvalue(exactVariable) range <- tclvalue(rangeVariable) explain <- tclvalue(explainVariable) smd <- tclvalue(smdVariable) output <- tclvalue(outputVariable) language <- tclvalue(languageVariable) dataSet <- activeDataSet() subset <- tclvalue(subsetVariable) putDialog("StatMedTableOne", list(group=group, cat=cat, cont=cont, contnonnormal=contnonnormal, exact=exact, range=range, explain=explain, smd=smd, output=output, language=language, subset = tclvalue(subsetVariable))) if(output=="Screen") output <- "" if(output=="CSVfile") { output <- tclvalue(tkgetSaveFile(filetypes= gettextRcmdr('{"All Files" {"*"}} {"Text Files" {".txt" ".TXT" ".csv" ".CSV"}}'), defaultextension="csv", initialfile=paste("tableone.csv", sep="."))) if (output == "") return() } # if (.Platform$OS.type != 'windows' & output=="clipboard"){ # errorCondition(recall=StatMedTableOne, message=gettextRcmdr("Clipboard can be selected only in Windows.")) # return() # } if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subdataSet <- dataSet } else{ subdataSet <- paste("subset(", dataSet, ", ", subset, ")", sep="") } if (length(group==1)){ levels <- eval(parse(text=paste("length(levels(factor(", subdataSet, "$", group, ")))", sep=""))) } if (exact=="auto" & length(group)==0) exact <- "exact" if (exact=="auto" & length(group)==1){ if (levels>=3){ exact <- "chisq" } else{ exact <- "exact" } } if (length(cat)+length(cont)+length(contnonnormal)==0){ errorCondition(recall=StatMedTableOne, message=gettextRcmdr("You must select a variable")) return() } closeDialog() # doItAndPrint("matCatTable <- NULL") # doItAndPrint("matContTable <- NULL") # doItAndPrint("matContnonnormalTable <- NULL") if(length(cat)>0){ catVariables <- paste('c("', cat[1], '"', sep="") if(length(cat)>1){ for (i in 2:length(cat)) { catVariables <- paste(catVariables, ', "', cat[i], '"', sep="") } } catVariables <- paste(catVariables, ")", sep="") if (length(group) == 0){ doItAndPrint(paste("CatTable <- CreateCatTable(vars = ", catVariables, ', data=', subdataSet, ")", sep="")) }else if(length(group)==1 & levels<2){ doItAndPrint(paste("CatTable <- CreateCatTable(vars = ", catVariables, ', data=', subdataSet, ")", sep="")) }else{ doItAndPrint(paste("CatTable <- CreateCatTable(vars = ", catVariables, ', strata="', group, '", data=', subdataSet, ")", sep="")) } if (exact=="chisq"){ doItAndPrint(paste("matCatTable <- print(CatTable, printToggle = FALSE, showAllLevels = TRUE, smd = ", smd, ")", sep="")) } else if (exact=="exact"){ doItAndPrint(paste("matCatTable <- print(CatTable, printToggle = FALSE, showAllLevels = TRUE, exact=", catVariables, ", smd = ", smd, ")", sep="")) } # doItAndPrint("matCatTable <- data.frame(matCatTable)") # doItAndPrint('if(colnames(matCatTable)[length(colnames(matCatTable))]=="test"){\nmatCatTable<-matCatTable[,1:length(colnames(matCatTable))-1]\n}') doItAndPrint('matCatTable <- matCatTable[,colnames(matCatTable)!="test"]') doItAndPrint("matCatTable <- cbind(Factor=row.names(matCatTable), matCatTable)") } if(length(cont)>0){ contVariables <- paste('c("', cont[1], '"', sep="") if(length(cont)>1){ for (i in 2:length(cont)) { contVariables <- paste(contVariables, ', "', cont[i], '"', sep="") } } contVariables <- paste(contVariables, ")", sep="") if (length(group) == 0){ doItAndPrint(paste("ContTable <- CreateContTable(vars = ", contVariables, ', data=', subdataSet, ")", sep="")) }else if(length(group)==1 & levels<2){ doItAndPrint(paste("ContTable <- CreateContTable(vars = ", contVariables, ', data=', subdataSet, ")", sep="")) }else{ doItAndPrint(paste("ContTable <- CreateContTable(vars = ", contVariables, ', strata="', group, '", data=', subdataSet, ")", sep="")) } doItAndPrint(paste("matContTable <- print(ContTable, printToggle = FALSE, explain = ", explain, ", smd = ", smd, ")", sep="")) # doItAndPrint("matContTable <- data.frame(matContTable)") # doItAndPrint('if(colnames(matContTable)[length(colnames(matContTable))]=="test"){\nmatContTable<-matContTable[,1:length(colnames(matContTable))-1]\n}') doItAndPrint('matContTable <- matContTable[,colnames(matContTable)!="test"]') #Add a dummy column to ContTable, because CatTable has a grouping column if(length(cat)>0) doItAndPrint('matContTable <- cbind(level="", matContTable)') if(language==0 & explain=="TRUE") { doItAndPrint('row.names(matContTable)[2:length(row.names(matContTable))] <- paste(substring(row.names(matContTable)[2:length(row.names(matContTable))], 1, nchar(row.names(matContTable)[2:length(row.names(matContTable))])-11), gettextRcmdr( "(mean (sd))"), sep="")') } doItAndPrint("matContTable <- cbind(Factor=row.names(matContTable), matContTable)") # if(length(cat)>0) doItAndPrint("matContTable <- matContTable[2:length(rownames(matContTable)),]") } if(length(contnonnormal)>0){ contnonnormalVariables <- paste('c("', contnonnormal[1], '"', sep="") if(length(contnonnormal)>1){ for (i in 2:length(contnonnormal)) { contnonnormalVariables <- paste(contnonnormalVariables, ', "', contnonnormal[i], '"', sep="") } } contnonnormalVariables <- paste(contnonnormalVariables, ")", sep="") if (length(group) == 0) { doItAndPrint(paste("ContnonnormalTable <- CreateContTable(vars = ", contnonnormalVariables, ', data=', subdataSet, ")", sep="")) }else if(length(group)==1 & levels<2){ doItAndPrint(paste("ContnonnormalTable <- CreateContTable(vars = ", contnonnormalVariables, ', data=', subdataSet, ")", sep="")) }else{ doItAndPrint(paste("ContnonnormalTable <- CreateContTable(vars = ", contnonnormalVariables, ', strata="', group, '", data=', subdataSet, ")", sep="")) } doItAndPrint(paste("matContnonnormalTable <- print(ContnonnormalTable, printToggle = FALSE, nonnormal = TRUE, explain = ", explain, ", minMax=", range, ", smd = ", smd, ")", sep="")) # doItAndPrint("matContnonnormalTable <- data.frame(matContnonnormalTable)") # doItAndPrint('if(colnames(matContnonnormalTable)[length(colnames(matContnonnormalTable))]=="test"){\nmatContnonnormalTable<-matContnonnormalTable[,1:length(colnames(matContnonnormalTable))-1]\n}') doItAndPrint('matContnonnormalTable <- matContnonnormalTable[,colnames(matContnonnormalTable)!="test"]') #Add a dummy column to ContTable, because CatTable has a grouping column if(length(cat)>0) doItAndPrint('matContnonnormalTable <- cbind(level="", matContnonnormalTable)') if(language==0 & explain=="TRUE") { if(range=="TRUE"){ doItAndPrint('row.names(matContnonnormalTable)[2:length(row.names(matContnonnormalTable))] <- paste(substring(row.names(matContnonnormalTable)[2:length(row.names(matContnonnormalTable))], 1, nchar(row.names(matContnonnormalTable)[2:length(row.names(matContnonnormalTable))])-16), gettextRcmdr( "(median [range])"), sep="")') } else { doItAndPrint('row.names(matContnonnormalTable)[2:length(row.names(matContnonnormalTable))] <- paste(substring(row.names(matContnonnormalTable)[2:length(row.names(matContnonnormalTable))], 1, nchar(row.names(matContnonnormalTable)[2:length(row.names(matContnonnormalTable))])-14), gettextRcmdr( "(median [IQR])"), sep="")') } } doItAndPrint("matContnonnormalTable <- cbind(Factor=row.names(matContnonnormalTable), matContnonnormalTable)") # if(length(cat)>0 | length(cont)>0) doItAndPrint("matContnonnormalTable <- matContnonnormalTable[2:length(rownames(matContnonnormalTable)),]") } if(length(cat)>0){ doItAndPrint("FinalTable <- as.matrix(matCatTable)") ncol <- eval(parse(text=paste("length(colnames(FinalTable))"))) doItAndPrint("tempStrata <- attributes(FinalTable)[[2]][2]") if(length(cont>0)){ # doItAndPrint(paste("FinalTable <- rbind(FinalTable, matrix(matContTable, ncol=", ncol, "))", sep="")) # doItAndPrint("FinalTable <- rbind(FinalTable, matContTable[2:length(rownames(matContTable)),])") doItAndPrint("FinalTable <- rbind(FinalTable, matContTable)") } if(length(contnonnormal>0)){ # doItAndPrint(paste("FinalTable <- rbind(FinalTable, matrix(matContnonnormalTable, ncol=", ncol, "))", sep="")) # doItAndPrint("FinalTable <- rbind(FinalTable, matContnonnormalTable[2:length(rownames(matContnonnormalTable)),])") doItAndPrint("FinalTable <- rbind(FinalTable, matContnonnormalTable)") } } if(length(cat)==0 & length(cont)>0){ doItAndPrint("FinalTable <- as.matrix(matContTable)") ncol <- eval(parse(text=paste("length(colnames(FinalTable))"))) doItAndPrint("tempStrata <- attributes(FinalTable)[[2]][2]") if(length(contnonnormal>0)){ # doItAndPrint(paste("FinalTable <- rbind(FinalTable, matrix(matContnonnormalTable, ncol=", ncol, "))", sep="")) # doItAndPrint("FinalTable <- rbind(FinalTable, matContnonnormalTable[2:length(rownames(matContnonnormalTable)),])") doItAndPrint("FinalTable <- rbind(FinalTable, matContnonnormalTable)") } } if(length(cat)==0 & length(cont)==0 & length(contnonnormal>0)){ doItAndPrint("FinalTable <- as.matrix(matContnonnormalTable)") doItAndPrint("tempStrata <- attributes(FinalTable)[[2]][2]") } doItAndPrint("attributes(FinalTable) <- c(list(dim=attributes(FinalTable)[[1]]), list(dimnames=c(attributes(FinalTable)[[2]][1], tempStrata)))") if(length(cat)>0) doItAndPrint('colnames(FinalTable)[2] <- "Group"') # if(length(group)==1) {if (levels>1) doItAndPrint('colnames(FinalTable)[length(colnames(FinalTable))] <- "p.value"')} if(length(group)==1) {if (levels>1) doItAndPrint('colnames(FinalTable)[colnames(FinalTable)=="p"] <- "p.value"')} # doItAndPrint("print(as.matrix(FinalTable), quote=FALSE)") # doItAndPrint("FinalTable <- cbind(Factor=row.names(FinalTable), FinalTable)") if(language==0) { doItAndPrint('colnames(FinalTable) <- gettextRcmdr( colnames(FinalTable))') # doItAndPrint('colnames(FinalTable)[1] <- gettextRcmdr( "Factor")') # doItAndPrint('if(colnames(FinalTable)[2] == "Group") colnames(FinalTable)[2] <- gettextRcmdr( "Group")') # if(length(group)==1) {if (levels>1) doItAndPrint('colnames(FinalTable)[length(colnames(FinalTable))] <- gettextRcmdr("p.value")')} } doItAndPrint("row0 <- colnames(FinalTable)") doItAndPrint("row1 <- FinalTable[1,]") doItAndPrint("row1 <- matrix(row1, nrow=1)") doItAndPrint("colnames(row1) <- row0") doItAndPrint('FinalTable <- FinalTable[which(rownames(FinalTable)!="n"),]') doItAndPrint("FinalTable <- rbind(n=row1, FinalTable)") # doItAndPrint("row.names(FinalTable) <- NULL") if(length(cat)>0){ # doItAndPrint("print(FinalTable[,2:length(FinalTable[1,])], quote=FALSE)") } else if (length(group)==1){ if(levels>1){ if(length(cont)==1 && length(contnonnormal)==0){ doItAndPrint(paste('rownames(FinalTable) <- c("n", "', cont[1], '")',sep="")) } if(length(cont)==0 && length(contnonnormal)==1){ doItAndPrint(paste('rownames(FinalTable) <- c("n", "', contnonnormal[1], '")',sep="")) } # doItAndPrint("print(FinalTable[,2:length(FinalTable[1,])], quote=FALSE)") } else { doItAndPrint('rownames(FinalTable) <- rep("", length(rownames(FinalTable)))') # doItAndPrint("print(FinalTable, quote=F)") } } else { doItAndPrint('rownames(FinalTable) <- rep("", length(rownames(FinalTable)))') # doItAndPrint("print(FinalTable, quote=F)") } # doItAndPrint("FinalTable <- cbind(Factor=row.names(FinalTable), FinalTable)") doItAndPrint("FinalTable <- rbind(row0, FinalTable)") if(length(group)==1) { if (levels>1) { doItAndPrint('row0 <- rep("", length(colnames(FinalTable)))') if(length(cat)==0){ doItAndPrint(paste('row0[2] <- "', group, '"', sep="")) }else{ doItAndPrint(paste('row0[3] <- "', group, '"', sep="")) } doItAndPrint("FinalTable <- rbind(row0, FinalTable)") } } doItAndPrint("finaltable_dataframe_print(FinalTable)") if (output=="clipboard"){ if (MacOSXP()==TRUE) { doItAndPrint('write.table(FinalTable, pipe("pbcopy"), sep = "\t", row.names = FALSE, col.names=FALSE)') } else { doItAndPrint('write.table(FinalTable, "clipboard", sep = "\t", row.names = FALSE, col.names=FALSE)') } } else { doItAndPrint(paste('write.table(FinalTable, file="', output, '", sep=",", row.names=FALSE, col.names=FALSE)', sep="")) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="tableone", apply="StatMedTableOne", reset="StatMedTableOne") tkgrid(getFrame(groupBox), sticky="nw") tkgrid(labelRcmdr(variableFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(categoryBox), labelRcmdr(variableFrame, text=" "), getFrame(contBox), labelRcmdr(variableFrame, text=" "), getFrame(contnonnormalBox), sticky="nw") tkgrid(variableFrame, sticky="nw") tkgrid(exactFrame, labelRcmdr(optionsFrame, text=" "), rangeFrame, labelRcmdr(optionsFrame, text=" "), explainFrame, labelRcmdr(optionsFrame, text=" "), smdFrame, sticky="nw") tkgrid(optionsFrame, sticky="w") tkgrid(outputFrame, labelRcmdr(options2Frame, text=" "), languageFrame, sticky="nw") tkgrid(options2Frame, sticky="w") # tkgrid(labelRcmdr(top, text=gettextRcmdr("Clipboard can be selected only in Windows."), fg="blue"), sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } objectCheck <- function(name, obj){ #obj <- objects() should be performed before executing this function. #Used in StatMedSummaryResults present <- 0 for(i in 1:length(obj)){ if (name==obj[i]) present <- 1 } # if (present==0) print(paste("Object ", name, " was not found.", sep="")) if (present==0) print(gettextRcmdr("You must perform analysis before outputting.")) return(present) } StatMedSummaryResults <- function() { defaults <- list(analysis="twoway", output="clipboard", language="1") dialog.values <- getDialog("StatMedSummaryResults", defaults) currentModel <- TRUE initializeDialog(title=gettextRcmdr("Summary table of results")) optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="analysis", buttons=c("twoway", "ttest", "survival", "ci", "logistic", "multireg", "cox", "finegray"), values=c("twoway", "ttest", "survival", "ci", "logistic", "multireg", "cox", "finegray"), initialValue=dialog.values$analysis, labels=gettextRcmdr(c("Two-way table", "T-test", "Survival test", "Cumulative incidence", "Multivariate logistic regression", "Multivariate linear regression", "Proportional hazard regression", "Fine-Gray regression")), title=gettextRcmdr("Test for outputting result")) radioButtons(optionsFrame, name="output", buttons=c("Clipboard", "CSVfile"), values=c("clipboard", "CSVfile"), initialValue=dialog.values$output, labels=gettextRcmdr(c("Clipboard", "CSV file")), title=gettextRcmdr("Output destination")) radioButtons(optionsFrame, name="language", buttons=c("Eng", "Local"), values=c("1", "0"), initialValue=dialog.values$language, labels=gettextRcmdr(c("English", "Local")), title=gettextRcmdr("Language")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Summary table of results"), "#####", sep="")) analysis <- tclvalue(analysisVariable) output <- tclvalue(outputVariable) language <- tclvalue(languageVariable) putDialog("StatMedSummaryResults", list(analysis=analysis, output=output, language=language)) if(analysis=="twoway") table <- "Fisher.summary.table" if(analysis=="ttest") table <- "summary.ttest" if(analysis=="survival") table <- "km.summary.table" if(analysis=="ci") table <- "ci.summary.table" if(analysis=="logistic") table <- "odds" if(analysis=="multireg") table <- "multireg.table" if(analysis=="cox") table <- "cox.table" if(analysis=="finegray") table <- "crr.table" if(output=="Screen") output <- "" if(output=="CSVfile") { output <- tclvalue(tkgetSaveFile(filetypes= gettextRcmdr('{"All Files" {"*"}} {"Text Files" {".txt" ".TXT" ".csv" ".CSV"}}'), defaultextension="csv", initialfile=paste(table, "csv", sep="."))) if (output == "") return() } # if (.Platform$OS.type != 'windows' & output=="clipboard"){ # errorCondition(recall=StatMedSummaryResults, message=gettextRcmdr("Clipboard can be selected only in Windows.")) # return() # } # findobject <- eval(parse(text=paste('objectCheck("', table, '", objects())', sep=""))) # doItAndPrint(paste('findobject <- objectCheck("', table, '", objects())', sep="")) # if(findobject==0){ # errorCondition(recall=StatMedSummaryResults, message=gettextRcmdr("You must perform analysis before outputting.")) # return() # } if(analysis=="twoway") doItAndPrint(paste('if(objectCheck("Fisher.summary.table", objects())) w.twoway(Fisher.summary.table, filename="', output, '", en=', language, ")", sep="")) if(analysis=="ttest") doItAndPrint(paste('if(objectCheck("summary.ttest", objects())) w.ttest(summary.ttest, filename="', output, '", en=', language, ")", sep="")) if(analysis=="survival") doItAndPrint(paste('if(objectCheck("km.summary.table", objects())) w.survival(km.summary.table, filename = "', output, '", en=', language, ")", sep="")) if(analysis=="ci") doItAndPrint(paste('if(objectCheck("ci.summary.table", objects())) w.ci(ci.summary.table, filename = "', output, '", en=', language, ")", sep="")) if(analysis=="logistic") doItAndPrint(paste('if(objectCheck("odds", objects())) w.multi(odds, filename = "', output, '", en=', language, ")", sep="")) if(analysis=="multireg") doItAndPrint(paste('if(objectCheck("multireg.table", objects())) w.multireg(multireg.table, filename = "', output, '", en=', language, ")", sep="")) if(analysis=="cox") doItAndPrint(paste('if(objectCheck("cox.table", objects())) w.multi(cox.table, filename = "', output, '", en=', language, ")", sep="")) if(analysis=="finegray") doItAndPrint(paste('if(objectCheck("crr.table", objects())) w.multi(crr.table, filename = "', output, '", en=', language, ")", sep="")) closeDialog() } OKCancelHelp(helpSubject="w.multi") # tkgrid(labelRcmdr(top, text=gettextRcmdr("Clipboard can be selected only in Windows."), fg="blue"), sticky="w") tkgrid(analysisFrame, labelRcmdr(optionsFrame, text=" "), outputFrame, labelRcmdr(optionsFrame, text=" "), languageFrame, sticky="nw") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=7, columns=2) } stsplit <- function (dataframe, timetoevent, event, timeon, covariate, timeoff){ Temp1 <- dataframe PatientsNumber <- length(Temp1[,1]) Temp1$start_td <- 0 Temp1$stop_td <- timetoevent Temp1$endpoint_td <- event Temp1$covariate_td <- covariate timeon <- ifelse(timeon<0, 0, timeon) timeoff <- ifelse(timeoff<0, 0, timeoff) for (i in 1:PatientsNumber){ Temp1$patientsnumber_td[i] <- i + 0.1 if ( is.na(timetoevent[i]) == TRUE || is.na(timeon[i])==TRUE || is.na(timeoff[i]) == TRUE || is.na(covariate[i]) == TRUE){ Temp1$covariate_td[i] <- NA } else { if (covariate[i] == 1 && timetoevent[i] > timeon[i]) { Temp1$stop_td[i] <- timeon[i] Temp2 <- Temp1[i,] Temp2$start_td[1] <- Temp1$stop_td[i] Temp2$stop_td[1] <- timetoevent[i] Temp2$patientsnumber_td[1] <- i + 0.2 if ( timeoff[i] > timeon[i] && timetoevent[i] > timeoff[i]){ Temp3 <- Temp2 Temp2$stop_td[1] <- timeoff[i] Temp3$start_td[1] <- Temp2$stop_td[1] Temp3$stop_td[1] <- timetoevent[i] Temp3$covariate_td[1] <- 0 Temp3$patientsnumber_td[1] <- i + 0.3 Temp2$endpoint_td[1] <- 0 Temp1<- rbind(Temp1, Temp3) } Temp1<- rbind(Temp1, Temp2) Temp1$endpoint_td[i] <- 0 } Temp1$covariate_td[i] <- 0 } } sortlist <- order(Temp1$patientsnumber_td) return (Temp1[sortlist,]) } stsplit.new <- function (dataframe, timetoevent, event, time, timeoff=0, td=NULL){ ##timetoevent, event, time should be given as variable name strings, not vectors ##time off should be given as 0 or 1. If 1, time will be treated as timeoff. Temp1 <- dataframe if(is.null(Temp1$start_td)){ Temp1$start_td <- 0 Temp1$stop_td <- eval(parse(text=paste("Temp1$", timetoevent, sep=""))) Temp1$endpoint_td <- eval(parse(text=paste("Temp1$", event, sep=""))) } if(eval(parse(text=paste("is.null(Temp1$", time, "_td)", sep="")))){ eval(parse(text=paste("Temp1$", time, "_td <- 0", sep=""))) eval(parse(text=paste("Temp1$", time, "_time <- Temp1$", time, sep=""))) } lines <- length(Temp1[,1]) if(is.null(Temp1$patientsnumber_td)){ Temp1$patientsnumber_td <- 1:lines } else { Temp1$patientsnumber_td <- floor(as.numeric(Temp1$patientsnumber_td)) } flag <- 0 for (i in 1:lines){ time.i <- eval(parse(text=paste("Temp1$", time, "_time[i]", sep=""))) if(!is.na(time.i) & time.i<0)time.i<-0 if ( is.na(Temp1$stop_td[i]) == TRUE || is.na(time.i)==TRUE){ if(timeoff==0){ eval(parse(text=paste("Temp1$", time, "_td[i] <- NA", sep=""))) } else { eval(parse(text=paste("Temp1$", td, "_td[i] <- NA", sep=""))) } } else { if (Temp1$start_td[i] <= time.i & Temp1$stop_td[i] > time.i) { Temp2 <- Temp1[i,] Temp2$start_td <- time.i Temp2$stop_td <- Temp1$stop_td[i] Temp1$stop_td[i] <- time.i Temp1$endpoint_td[i] <- 0 flag <- 1 if(timeoff==0){ eval(parse(text=paste("Temp2$", time, "_td <- ", 1, sep=""))) } else { eval(parse(text=paste("Temp2$", td, "_td <- ", 0, sep=""))) } Temp1<- rbind(Temp1, Temp2) } else { if(i>=2 & timeoff==0) { if(flag ==1 & floor(Temp1$patientsnumber_td[i])==floor(Temp1$patientsnumber_td[i-1])){ eval(parse(text=paste("Temp1$", time, "_td[i] <- 1", sep=""))) } else { flag <- 0 } } } } } sortlist <- order(Temp1$patientsnumber_td + Temp1$start_td/(max(Temp1$start_td)+1)) Temp1 <- Temp1[sortlist,] flag <- 0 Temp1$patientsnumber_td[1] <- Temp1$patientsnumber_td[1]+0.1 for(i in 2:length(Temp1[,1])){ if(Temp1$patientsnumber_td[i]==floor(Temp1$patientsnumber_td[i-1])){ Temp1$patientsnumber_td[i] <- Temp1$patientsnumber_td[i-1]+0.1 } else { Temp1$patientsnumber_td[i] <- Temp1$patientsnumber_td[i]+0.1 } } return (Temp1) } Mantel.Byar <- function(Group=NULL, Event=TempTD$endpoint_td, StartTime=TempTD$start_td, StopTime=TempTD$stop_td, method=c("SAS", "Tominaga"), plot=0, landmark=0) { #modified from logrank test in http://aoki2.si.gunma-u.ac.jp/R/logrank.html #Reuire TempTD dataset created by Cox with TD variable in EZR Group.name <- Group if(!is.null(Group)){ Group <- eval(parse(text=paste("TempTD$", Group, sep=""))) } else { cn <- colnames(TempTD) len.cn <- length(cn) if(substring(cn[len.cn], nchar(cn[len.cn])-2, nchar(cn[len.cn]))!="_td") { print("Mantel.Byar() function should be done just after Cox proportional hazard modeling with time-deopendent covariate.") } else { Group.name <- cn[len.cn] Group <- eval(parse(text=paste("TempTD$", cn[len.cn], sep=""))) } } method <- match.arg(method) data.name <- sprintf("StartTime: %s, StopTime: %s, Event: %s, Group: %s", deparse(substitute(StartTime)), deparse(substitute(StopTime)), deparse(substitute(Event)), paste("TempTD$", Group.name, sep="")) OK <- complete.cases(Group, Event, StartTime, StopTime) Group <- Group[OK] Event <- Event[OK] StartTime <- StartTime[OK] StopTime <- StopTime[OK] Start <- pmin(StartTime, StopTime) #for samples with StartTime>StopTime Stop <- pmax(StartTime, StopTime) StartTime <- Start StopTime <- Stop len <- length(Group) stopifnot(length(Event) == len, length(StopTime) == len) tg <- table(c(StopTime, rep(NA, 4)), c(Group, 1, 1, 2, 2)*10+c(Event, 1, 0, 1, 0)) k <- nrow(tg) nia <- table(Group)[1] nib <- len-nia na <- c(nia, (rep(nia, k)-cumsum(tg[,1]+tg[,2]))[-k]) nb <- c(nib, (rep(nib, k)-cumsum(tg[,3]+tg[,4]))[-k]) #following part is different from log-rank test minus <- NULL for (i in 1:length(tg[,1])){ if(as.integer(rownames(tg))[i]==0){ minus[i] <- sum((as.integer(rownames(tg))[i] < StartTime)) } else { minus[i] <- sum((as.integer(rownames(tg))[i] <= StartTime)) } } nb <- nb - minus #Following part is same wtih log-ranktest da <- tg[,2] db <- tg[,4] dt <- da+db nt <- na+nb d <- dt/nt O <- c(sum(da), sum(db)) ea <- na*d eb <- nb*d E <- c(sum(ea), sum(eb)) result <- data.frame(da, db, dt, na, nb, nt, d, ea, eb) if (method == "Tominaga") { method <- "Mantel Byar(Tominaga)" chi <- sum((O-E)^2/E) } else { method <- "Mantel Byar test" v <- sum(dt*(nt-dt)/(nt-1)*na/nt*(1-na/nt), na.rm=TRUE) chi <- (sum(da)-sum(na*d))^2/v # print (paste("(O-E) = ", sum(da)-sum(na*d), ", V=", v, sep="") ) # HR <- 1 / exp((sum(da)-sum(na*d))/v) # print (paste("HR = ", HR, sep="") ) } P <- pchisq(chi, 1, lower.tail=FALSE) if(plot>=1){ #If plot>=1, draw Simon Makuch plot with a landmark as specified. StartTime2 <- StartTime[StopTime>=landmark] StopTime2 <- StopTime[StopTime>=landmark] Event2 <- Event[StopTime>=landmark] Group2 <- Group[StopTime>=landmark] km <- survfit(Surv(StartTime2,StopTime2,Event2)~Group2, na.action = na.omit, conf.type="log-log") summary(km) # diff <- survdiff(Surv(StopTime2,Event2)~Group2) n.atrisk.G1 <- NULL n.atrisk.G2 <- NULL # n.atrisk.G1[1] <- diff$n[1] #To correct number at risk at zero point in no event group # n.atrisk.G2[1] <- 0 len <- nchar("Group2") legend <- substring(names(km$strata), len+2) # windows(width=7, height=7); par(lwd=1, las=1, family="sans", cex=1) # dev.new() if (.Platform$OS.type == 'windows'){ justDoIt(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep="")) } else if (MacOSXP()==TRUE) { justDoIt(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep="")) } else { justDoIt(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep="")) } mar <- par("mar") mar[1] <- mar[1] + length(km$strata) + 0.5 mar[2] <- mar[2] + 2 par(mar=mar) opar <- par(mar = mar) on.exit(par(opar)) # plot(km, ylab="Probability", bty="l", col=1:32, lty=1, lwd=1, conf.int=FALSE, mark.time=TRUE) if(plot==1) plot(km, ylab="Probability", bty="l", col=1:32, lty=1, lwd=1, conf.int=FALSE, mark.time=TRUE) if(plot==2) plot(km, ylab="Probability", bty="l", col=1, lty=1:32, lwd=1, conf.int=FALSE, mark.time=TRUE) if(plot>=3) plot(km, ylab="Probability", bty="l", col=1, lty=1, lwd=1:32, conf.int=FALSE, mark.time=TRUE) xticks <- axTicks(1) # n.atrisk <- nrisk(km, xticks) #nrisk does not work properly in Simon-Makuch plot for(i in 1:length(xticks)){ n.atrisk.G1[i] <- length(which(Group2==0 & StartTime2<=xticks[i] & xticks[i]<=StopTime2)) n.atrisk.G2[i] <- length(which(Group2==1 & StartTime2<=xticks[i] & xticks[i]<=StopTime2)) } n.atrisk <- rbind(n.atrisk.G1, n.atrisk.G2) colnames(n.atrisk) <- xticks for (i in 1:length(km$strata)){axis(1, at = xticks, labels = n.atrisk[i,], line=3+i, tick = FALSE)} for (i in 1:length(km$strata)){mtext(legend[i], at=-(xticks[2]-xticks[1])/2, side=1, line=4+i, cex=1)} title(xlab = "Number at risk", line = 3.5, adj = 0) # legend ("topright", legend, col=1:32, lty=1, lwd=1, box.lty=0, title="Time-dependent covariate") # if(plot==1) legend ("topright", legend, col=1:32, lty=1, lwd=1, box.lty=0, title="Time-dependent covariate") if(plot==1) legend ("topright", legend, col=1:32, lty=1, lwd=1, box.lty=0, title=Group.name) if(plot==2) legend ("topright", legend, col=1, lty=1:32, lwd=1, box.lty=0, title=Group.name) if(plot>=3) legend ("topright", legend, col=1, lty=1, lwd=1:32, box.lty=0, title=Group.name) } return(structure(list(statistic=c("X-squared"=chi), parameter=c(df=1), p.value=P, method=method, data.name=data.name, result=result), class="htest")) } step.p.lm <- function (lm, dataframe.name, waldtest=0, subset=NULL){ formula1 <- lm$terms[[2]] res <- summary(lm) reslist <- rownames(res$coefficients)[2:length(rownames(res$coefficients))] var <- colnames(lm$model)[2:length(colnames(lm$model))] nvar <- length(var) dum <- NA fac <- NA for (i in 1:length(reslist)){ dum[i] <- NA fac[i] <- NA if (regexpr(".Dummy.", reslist[i])>0) { #Check dummy variables dum[i] <- substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])+6) next } for (j in 1:nchar(reslist[i])){ #Check factors if (substring(reslist[i], j, j)=="["){ fac[i] <- substring(reslist[i], 1, j) next } } } dum.list <- levels(factor(dum)) fac.list <- levels(factor(fac)) reslist <- rownames(res$coefficients)[2:length(rownames(res$coefficients))] p.value <- res$coefficients[,4][2:length(rownames(res$coefficients))] subset <- ifelse(is.null(subset), "", paste(", subset=", subset, sep="")) while(max(p.value) >= 0.05) { colnames(res$coefficients) <- gettextRcmdr( colnames(res$coefficients)) print(res$coefficients) if(length(dum.list)!=0){ #set the p values of dummy variables at minimum value for(i in 1:length(dum.list)){ if (length(p.value[substring(reslist, 1, nchar(dum.list[i]))==dum.list[i]])>=2){ wald <- wald.test(vcov(lm), lm$coef, which(substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i])) p.value[substring(reslist, 1, nchar(dum.list[i]))==dum.list[i]] <- wald[[6]][[1]][3] } } } if(length(fac.list)!=0){ #set the p values of factors at minimum value for(i in 1:length(fac.list)){ if (length(p.value[substring(reslist, 1, nchar(fac.list[i]))==fac.list[i]])>=2){ wald <- wald.test(vcov(lm), lm$coef, which(substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i])) p.value[substring(reslist, 1, nchar(fac.list[i]))==fac.list[i]] <- wald[[6]][[1]][3] } } } if(max(p.value) < 0.05) break del <- reslist[p.value==max(p.value)] if(length(del)>1)del <- del[1] delete.flag <- 0 if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (substring(del, 1, nchar(dum.list[i]))==dum.list[i]){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", substring(del, 1, regexpr(".Dummy.", del)+6), " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test"), "\n\n", sep="")) var <- subset(var, substring(var, 1, nchar(dum.list[i]))!=dum.list[i]) delete.flag <- 1 } } } if(length(fac.list)!=0){ for(i in 1:length(fac.list)){ if (substring(del, 1, nchar(fac.list[i]))==fac.list[i]){ del <- substring(fac.list[i], 1, nchar(fac.list[i])-1) cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) var <- subset(var, var!=del) delete.flag <- 1 } } } if(delete.flag==0){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), ")\n\n", sep="")) var <- subset(var, var!=del) } nvar <- length(var) if (nvar==0) { cat("\n", gettextRcmdr("-----All variables were removed from the model."), "\n\n", sep="") nvar <- 0 break } formula <- paste(formula1, " ~ ", var[1], sep="") if (nvar > 1){ for(i in 2:nvar){ formula <- paste(formula, "+", var[i]) } } command <- paste("lm <- lm(", formula, ", data=", dataframe.name, subset, ")", sep="") # cat(command, "\n\n") eval(parse(text=command)) res <- summary(lm) reslist <- rownames(res$coefficients)[2:length(rownames(res$coefficients))] p.value <- res$coefficients[,4][2:length(rownames(res$coefficients))] } if(nvar>=1){ cat("\n", gettextRcmdr("-----Final model"), "\n\n", sep="") print(res$coefficients) if(waldtest==1) {waldtest(lm)} } } step.p.glm <- function (glm, dataframe.name, waldtest=0, subset=NULL){ formula1 <- glm$terms[[2]] res <- summary(glm) reslist <- rownames(res$coefficients)[2:length(rownames(res$coefficients))] var <- colnames(glm$model)[2:length(colnames(glm$model))] nvar <- length(var) dum <- NA fac <- NA for (i in 1:length(reslist)){ dum[i] <- NA fac[i] <- NA if (regexpr(".Dummy.", reslist[i])>0) { dum[i] <- substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])+6) next } for (j in 1:nchar(reslist[i])){ if (substring(reslist[i], j, j)=="["){ fac[i] <- substring(reslist[i], 1, j) next } } } dum.list <- levels(factor(dum)) fac.list <- levels(factor(fac)) reslist <- rownames(res$coefficients)[2:length(rownames(res$coefficients))] p.value <- res$coefficients[,4][2:length(rownames(res$coefficients))] subset <- ifelse(is.null(subset), "", paste(", subset=", subset, sep="")) while(max(p.value) >= 0.05) { odds <- data.frame(exp(res$coef[,1:2] %*% rbind(c(1,1,1), 1.96*c(0,-1,1)))) odds <- cbind(odds, res$coefficients[,4]) odds <- signif(odds, digits=3) names(odds) <- gettextRcmdr(c("odds ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) print(odds) if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (length(p.value[substring(reslist, 1, nchar(dum.list[i]))==dum.list[i]])!=0){ wald <- wald.test(vcov(glm), glm$coef, which(substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i])) p.value[substring(reslist, 1, nchar(dum.list[i]))==dum.list[i]] <- wald[[6]][[1]][3] } } } if(length(fac.list)!=0){ for(i in 1:length(fac.list)){ if (length(p.value[substring(reslist, 1, nchar(fac.list[i]))==fac.list[i]])!=0){ wald <- wald.test(vcov(glm), glm$coef, which(substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i])) p.value[substring(reslist, 1, nchar(fac.list[i]))==fac.list[i]] <- wald[[6]][[1]][3] } } } if(max(p.value) < 0.05) break del <- reslist[p.value==max(p.value)] if(length(del)>1)del <- del[1] delete.flag <- 0 if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (substring(del, 1, nchar(dum.list[i]))==dum.list[i]){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", substring(del, 1, regexpr(".Dummy.", del)+6), " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) var <- subset(var, substring(var, 1, nchar(dum.list[i]))!=dum.list[i]) delete.flag <- 1 } } } if(length(fac.list)!=0){ for(i in 1:length(fac.list)){ if (substring(del, 1, nchar(fac.list[i]))==fac.list[i]){ del <- substring(fac.list[i], 1, nchar(fac.list[i])-1) cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) var <- subset(var, var!=del) delete.flag <- 1 } } } if(delete.flag==0){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), ")\n\n", sep="")) var <- subset(var, var!=del) } nvar <- length(var) if (nvar==0) { cat("\n", gettextRcmdr("-----All variables were removed from the model."), "\n\n", sep="") nvar <- 0 break } formula <- paste(formula1, " ~ ", var[1], sep="") if (nvar > 1){ for(i in 2:nvar){ formula <- paste(formula, "+", var[i]) } } command <- paste("glm <- glm(", formula, ", data=", dataframe.name, subset, ", family=binomial(logit))", sep="") # cat(command, "\n\n") eval(parse(text=command)) res <- summary(glm) reslist <- rownames(res$coefficients)[2:length(rownames(res$coefficients))] p.value <- res$coefficients[,4][2:length(rownames(res$coefficients))] } if(nvar>=1){ odds <- data.frame(exp(res$coef[,1:2] %*% rbind(c(1,1,1), 1.96*c(0,-1,1)))) odds <- cbind(odds, res$coefficients[,4]) odds <- signif(odds, digits=3) names(odds) <- gettextRcmdr(c("odds ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) cat("\n", gettextRcmdr("-----Final model"), "\n\n", sep="") print(odds) if(waldtest==1) {waldtest(glm)} } } step.p.cox <- function (cox, dataframe.name, waldtest=0, subset=NULL){ formula1 <- cox$terms[[2]] # formula1 <- paste("Surv(", formula1[[2]], ", ", formula1[[3]], "==1)", sep="") formula1 <- paste("Surv(", formula1[[2]], ", ", as.character(formula1[[3]][2]), "==1)", sep="") #Change from EZR 1.20 according to the update of survival package res <- summary(cox) reslist <- rownames(res$coefficients) dum <- NA fac <- NA k <- 1 var <- NA for (i in 1:length(reslist)){ dum[i] <- NA fac[i] <- NA if (regexpr(".Dummy.", reslist[i])>0) { dum[i] <- substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])+6) var[k] <- reslist[i] k <- k+1 next } for (j in 1:nchar(reslist[i])){ if (substring(reslist[i], j, j)=="["){ fac[i] <- substring(reslist[i], 1, j) reslist[i] <- substring(fac[i], 1, nchar(fac[i])-1) next } } if (k==1) { var[k] <- reslist[i] k <- k+1 } else if (reslist[i]!=var[k-1]) { var[k] <- reslist[i] k <- k+1 } } dum.list <- levels(factor(dum)) fac.list <- levels(factor(fac)) nvar <- length(var) res <- summary(cox) p.value <- res$coefficients[,5] subset <- ifelse(is.null(subset), "", paste(", subset=", subset, sep="")) print(res$call) cat("\n") while(max(p.value) >= 0.05) { # if(nvar==1){ if(length(res$coefficients[,5])==1){ cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4) rownames(cox.table) <- rownames(res$coefficients) colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } else { cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4) cox.table <- data.frame(cox.table) names(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } print(cox.table) if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (length(p.value[substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i]])>=2){ wald <- wald.test(cox$var, cox$coef, which(substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i])) p.value[substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i]] <- wald[[6]][[1]][3] } } } if(length(fac.list)!=0){ for(i in 1:length(fac.list)){ if (length(p.value[substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i]])>=2){ wald <- wald.test(cox$var, cox$coef, which(substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i])) p.value[substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i]] <- wald[[6]][[1]][3] } } } if(max(p.value) < 0.05) break del <- rownames(res$coefficients)[p.value==max(p.value)] if(length(del)>1) del <- del[1] delete.flag <- 0 if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (substring(del, 1, nchar(dum.list[i]))==dum.list[i]){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", dum.list[i], " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) var <- subset(var, substring(var, 1, nchar(dum.list[i]))!=dum.list[i]) delete.flag <- 1 } } } if(length(fac.list)!=0){ for(i in 1:length(fac.list)){ if (substring(del, 1, nchar(fac.list[i]))==fac.list[i]){ del <- substring(fac.list[i], 1, nchar(fac.list[i])-1) cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) var <- subset(var, var!=del) delete.flag <- 1 } } } if(delete.flag==0){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), ")\n\n", sep="")) var <- subset(var, var!=del) } nvar <- length(var) if (nvar==0) { cat("\n", gettextRcmdr("-----All variables were removed from the model."), "\n\n", sep="") break } formula <- paste(formula1, " ~ ", var[1], sep="") if (nvar > 1){ for(i in 2:nvar){ formula <- paste(formula, "+", var[i]) } } command <- paste("cox <- coxph(", formula, ", data=", dataframe.name, subset, ', method="breslow")', sep="") cat(command, "\n\n") eval(parse(text=command)) res <- summary(cox) p.value <- res$coefficients[,5] } # if(nvar==1){ if(length(res$coefficients[,5])==1){ cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4) rownames(cox.table) <- rownames(res$coefficients) colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } # if (nvar>=2){ if (length(res$coefficients[,5])>=2){ cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4) cox.table <- data.frame(cox.table) names(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } if(nvar>=1){ cat("\n", gettextRcmdr("-----Final model"), "\n\n", sep="") print(cox.table) if(waldtest==1) {waldtest(cox)} } } step.p.coxtd <- function (cox, dataframe.name, waldtest=0, subset=NULL){ formula1 <- "Surv(start_td, stop_td, endpoint_td==1)" #Only the different point from step.p.cox res <- summary(cox) reslist <- rownames(res$coefficients) dum <- NA fac <- NA k <- 1 var <- NA for (i in 1:length(reslist)){ dum[i] <- NA fac[i] <- NA if (regexpr(".Dummy.", reslist[i])>0) { dum[i] <- substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])+6) var[k] <- reslist[i] k <- k+1 next } for (j in 1:nchar(reslist[i])){ if (substring(reslist[i], j, j)=="["){ fac[i] <- substring(reslist[i], 1, j) reslist[i] <- substring(fac[i], 1, nchar(fac[i])-1) next } } if (k==1) { var[k] <- reslist[i] k <- k+1 } else if (reslist[i]!=var[k-1]) { var[k] <- reslist[i] k <- k+1 } } dum.list <- levels(factor(dum)) fac.list <- levels(factor(fac)) nvar <- length(var) res <- summary(cox) p.value <- res$coefficients[,5] subset <- ifelse(is.null(subset), "", paste(", subset=", subset, sep="")) print(res$call) cat("\n") while(max(p.value) >= 0.05) { # if(nvar==1){ if(length(res$coefficients[,5])==1){ cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4) rownames(cox.table) <- rownames(res$coefficients) colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } else { cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4) cox.table <- data.frame(cox.table) names(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } print(cox.table) if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (length(p.value[substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i]])>=2){ wald <- wald.test(cox$var, cox$coef, which(substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i])) p.value[substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i]] <- wald[[6]][[1]][3] } } } if(length(fac.list)!=0){ for(i in 1:length(fac.list)){ if (length(p.value[substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i]])>=2){ wald <- wald.test(cox$var, cox$coef, which(substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i])) p.value[substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i]] <- wald[[6]][[1]][3] } } } if(max(p.value) < 0.05) break del <- rownames(res$coefficients)[p.value==max(p.value)] if(length(del)>1) del <- del[1] delete.flag <- 0 if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (substring(del, 1, nchar(dum.list[i]))==dum.list[i]){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", dum.list[i], " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) var <- subset(var, substring(var, 1, nchar(dum.list[i]))!=dum.list[i]) delete.flag <- 1 } } } if(length(fac.list)!=0){ for(i in 1:length(fac.list)){ if (substring(del, 1, nchar(fac.list[i]))==fac.list[i]){ del <- substring(fac.list[i], 1, nchar(fac.list[i])-1) cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) var <- subset(var, var!=del) delete.flag <- 1 } } } if(delete.flag==0){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), ")\n\n", sep="")) var <- subset(var, var!=del) } nvar <- length(var) if (nvar==0) { cat("\n", gettextRcmdr("-----All variables were removed from the model."), "\n\n", sep="") break } formula <- paste(formula1, " ~ ", var[1], sep="") if (nvar > 1){ for(i in 2:nvar){ formula <- paste(formula, "+", var[i]) } } command <- paste("cox <- coxph(", formula, ", data=", dataframe.name, subset, ', method="breslow")', sep="") cat(command, "\n\n") eval(parse(text=command)) res <- summary(cox) p.value <- res$coefficients[,5] } # if(nvar==1){ if(length(res$coefficients[,5])==1){ cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4) rownames(cox.table) <- rownames(res$coefficients) colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } # if (nvar>=2){ if (length(res$coefficients[,5])>=2){ cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4) cox.table <- data.frame(cox.table) names(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } if(nvar>=1){ cat("\n", gettextRcmdr("-----Final model"), "\n\n", sep="") print(cox.table) if(waldtest==1) {waldtest(cox)} } } step.p.crr <- function (crr, cov, dataframe.name, waldtest=0, subset=NULL){ dataframe.name <- ifelse(is.null(subset), dataframe.name, paste("subset(", dataframe.name, ", ", subset, ")",sep="")) command <- paste("cbind(", dataframe.name, "$", cov[1], sep="") if(length(cov)>1){ for(i in 2:length(cov)){ command <- paste(command, ", ", dataframe.name, "$", cov[i], sep="") } } command <- paste(command, ")", sep="") cov.matrix <- eval(parse(text=command)) ncov <- length(cov) dum <- NA for (i in 1:ncov){ dum[i] <- NA if (regexpr(".Dummy.", cov[i])>0) { dum[i] <- substring(cov[i], 1, regexpr(".Dummy.", cov[i])+6) } } dum.list <- levels(factor(dum)) call <- as.character(crr$call) command <- paste("with(", dataframe.name, ", crr(", call[2], ", ", call[3], ", cov.matrix, failcode=", call[5], ", cencode=", call[6], ", na.action=na.omit))", sep="") res <- summary(crr) p.value <- res$coef[,5] # print(command) cat("\n") while(max(p.value) >= 0.05) { if(ncov==1){ crr.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), res$coef[,5]), digits=4) } else { crr.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coef[,5]), digits=4) } rownames(crr.table) <- cov colnames(crr.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) print(crr.table) if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (length(p.value[substring(cov, 1, nchar(dum.list[i]))==dum.list[i]])!=0){ wald <- wald.test(crr$var, crr$coef, which(substring(cov, 1, nchar(dum.list[i]))==dum.list[i])) p.value[substring(cov, 1, nchar(dum.list[i]))==dum.list[i]] <- wald[[6]][[1]][3] } } } if(max(p.value) < 0.05) break del <- cov[p.value==max(p.value)] if(length(del)>1)del <- del[1] delete.flag <- 0 if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (substring(del, 1, nchar(dum.list[i]))==dum.list[i]){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", dum.list[i], " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) cov.matrix <- cov.matrix[,substring(cov, 1, nchar(dum.list[i]))!=dum.list[i]] cov <- subset(cov, substring(cov, 1, nchar(dum.list[i]))!=dum.list[i]) delete.flag <- 1 } } } if(delete.flag==0){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), ")\n\n", sep="")) if(is.matrix(cov.matrix)){ cov.matrix <- cov.matrix[,cov!=del] } else { cov.matrix <- cov.matrix[cov!=del] } cov <- cov[cov!=del] } ncov <- length(cov) if (ncov==0) { cat("\n", gettextRcmdr("-----All variables were removed from the model."), "\n\n", sep="") break } command <- paste("crr <- ", command, sep="") eval(parse(text=command)) res <- summary(crr) p.value <- res$coef[,5] } if(ncov>0){ if(ncov==1){ crr.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), res$coef[,5]), digits=4) } else { crr.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coef[,5]), digits=4) } rownames(crr.table) <- cov colnames(crr.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) cat("\n", gettextRcmdr("-----Final model"), "\n\n", sep="") print(crr.table) if (waldtest==1) waldtest.crr(crr, rownames(crr.table)) } } step.p.coxcrrtd <- function (cox, dataframe.name, waldtest=0, subset=NULL){ formula1 <- "Surv(fgstart, fgstop, fgstatus)" #Only the different point from step.p.cox res <- summary(cox) reslist <- rownames(res$coefficients) dum <- NA fac <- NA k <- 1 var <- NA for (i in 1:length(reslist)){ dum[i] <- NA fac[i] <- NA if (regexpr(".Dummy.", reslist[i])>0) { dum[i] <- substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])+6) var[k] <- reslist[i] k <- k+1 next } for (j in 1:nchar(reslist[i])){ if (substring(reslist[i], j, j)=="["){ fac[i] <- substring(reslist[i], 1, j) reslist[i] <- substring(fac[i], 1, nchar(fac[i])-1) next } } if (k==1) { var[k] <- reslist[i] k <- k+1 } else if (reslist[i]!=var[k-1]) { var[k] <- reslist[i] k <- k+1 } } dum.list <- levels(factor(dum)) fac.list <- levels(factor(fac)) nvar <- length(var) res <- summary(cox) p.value <- res$coefficients[,5] subset <- ifelse(is.null(subset), "", paste(", subset=", subset, sep="")) print(res$call) cat("\n") while(max(p.value) >= 0.05) { # if(nvar==1){ if(length(res$coefficients[,5])==1){ cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4) rownames(cox.table) <- rownames(res$coefficients) colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } else { cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4) cox.table <- data.frame(cox.table) names(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } print(cox.table) if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (length(p.value[substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i]])>=2){ wald <- wald.test(cox$var, cox$coef, which(substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i])) p.value[substring(rownames(res$coefficients), 1, nchar(dum.list[i]))==dum.list[i]] <- wald[[6]][[1]][3] } } } if(length(fac.list)!=0){ for(i in 1:length(fac.list)){ if (length(p.value[substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i]])>=2){ wald <- wald.test(cox$var, cox$coef, which(substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i])) p.value[substring(rownames(res$coefficients), 1, nchar(fac.list[i]))==fac.list[i]] <- wald[[6]][[1]][3] } } } if(max(p.value) < 0.05) break del <- rownames(res$coefficients)[p.value==max(p.value)] if(length(del)>1) del <- del[1] delete.flag <- 0 if(length(dum.list)!=0){ for(i in 1:length(dum.list)){ if (substring(del, 1, nchar(dum.list[i]))==dum.list[i]){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", dum.list[i], " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) var <- subset(var, substring(var, 1, nchar(dum.list[i]))!=dum.list[i]) delete.flag <- 1 } } } if(length(fac.list)!=0){ for(i in 1:length(fac.list)){ if (substring(del, 1, nchar(fac.list[i]))==fac.list[i]){ del <- substring(fac.list[i], 1, nchar(fac.list[i])-1) cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), " ", gettextRcmdr("by Wald test)"), "\n\n", sep="")) var <- subset(var, var!=del) delete.flag <- 1 } } } if(delete.flag==0){ cat(paste("\n", gettextRcmdr("-----Remove"), " ", del, " ", gettextRcmdr("from the model. (p="), signif(max(p.value),4), ")\n\n", sep="")) var <- subset(var, var!=del) } nvar <- length(var) if (nvar==0) { cat("\n", gettextRcmdr("-----All variables were removed from the model."), "\n\n", sep="") break } formula <- paste(formula1, " ~ ", var[1], sep="") if (nvar > 1){ for(i in 2:nvar){ formula <- paste(formula, "+", var[i]) } } command <- paste("cox <- coxph(", formula, ", data=", dataframe.name, subset, ', weight=fgwt, method="breslow")', sep="") cat(command, "\n\n") eval(parse(text=command)) res <- summary(cox) p.value <- res$coefficients[,5] } # if(nvar==1){ if(length(res$coefficients[,5])==1){ cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4) rownames(cox.table) <- rownames(res$coefficients) colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } # if (nvar>=2){ if (length(res$coefficients[,5])>=2){ cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4) cox.table <- data.frame(cox.table) names(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) } if(nvar>=1){ cat("\n", gettextRcmdr("-----Final model"), "\n\n", sep="") print(cox.table) if(waldtest==1) {waldtest(cox)} } } step.AIC.crr <- function (crr, cov, dataframe.name, BIC = 0, subset = NULL, waldtest=0) { method <- ifelse(BIC==0, "AIC", "BIC") dataframe.name <- ifelse(is.null(subset), dataframe.name, paste("subset(", dataframe.name, ", ", subset, ")", sep = "")) command <- paste(paste(dataframe.name, "$", cov, sep=""), collapse=", ") command <- paste("cbind(", command, ")", sep = "") cov.matrix <- eval(parse(text = command)) ncov <- length(cov) dum <- NA #NA for non-dummy variables for (i in 1:ncov) { dum[i] <- NA if (regexpr(".Dummy.", cov[i]) > 0) { dum[i] <- substring(cov[i], 1, regexpr(".Dummy.", cov[i]) + 6) } } dum.list <- levels(factor(dum)) #list of dummmy variables ("....Dummy.") dum.list.num <- NA if (length(dum.list)>=1){ for (i in 1:length(dum.list)){ dum.list.num[i] <- length(cov[substring(cov, 1, nchar(dum.list[i]))==dum.list[i]]) } } if (length(dum.list) == 0){ var.list <- cov } else { var.list <- c(cov[is.na(dum)], substring(dum.list, 1, nchar(dum.list)-7)) } cov <- c(cov[is.na(dum)], cov[!is.na(dum)]) #rearrange cov according to the var.list dum <- c(dum[is.na(dum)], dum[!is.na(dum)]) #rearrange dum according to the var.list j <- length(cov[is.na(dum)]) cov.to.var.list <- 1:j if (length(dum.list)>=1){ for (i in 1:length(dum.list)){ j <- j + 1 cov.to.var.list <- c(cov.to.var.list, rep(j, dum.list.num[i])) } } in.model <- rep(1, length(var.list)) #1 if in model var.list.dum <- rep(1, length(var.list)) #1 if dummy if(length(cov[is.na(dum)])>=1) var.list.dum[1:length(cov[is.na(dum)])] <- 0 call <- as.character(crr$call) command <- paste("with(", dataframe.name, ", crr(", call[2], ", ", call[3], ", cov.matrix, failcode=", call[5], ", cencode=", call[6], ", na.action=na.omit))", sep = "") currentAIC <- crrAIC(crr, BIC) cat("\n\n", gettextRcmdr( "Current model:"), " ", paste(var.list[in.model==1], collapse=" + "), "\n", sep="") cat(method, " = ", currentAIC, "\n\n", sep="") cat("\n") flag <- 0 while (flag==0) { ####while routine for forward/backward selection newAIC <- NA action <- NA target <- NA for (i in 1:length(var.list)){ if (in.model[i]==0){ action[i] <- "+" target[i] <- var.list[i] in.model[i] <- 1 command <- "cbind(" first.var <- 1 for (j in 1:length(var.list)){ if (in.model[j]==1){ if (first.var==0){ command <- paste(command, ",", sep="") } command2 <- paste(paste(dataframe.name, "$", cov[cov.to.var.list==j], sep=""), collapse=",") command <- paste(command, command2, sep="") first.var <- 0 } } command <- paste(command, ")", sep = "") cov.matrix <- eval(parse(text = command)) in.model[i] <- 0 command <- paste("with(", dataframe.name, ", crr(", call[2], ", ", call[3], ", cov.matrix, failcode=", call[5], ", cencode=", call[6], ", na.action=na.omit))", sep = "") crr2 <- eval(parse(text = command)) newAIC[i] <- crrAIC(crr2, BIC) } else { action[i] <- "-" target[i] <- var.list[i] in.model[i] <- 0 if (sum(in.model)>0){ command <- "cbind(" first.var <- 1 for (j in 1:length(var.list)){ if (in.model[j]==1){ if (first.var==0){ command <- paste(command, ",", sep="") } command2 <- paste(paste(dataframe.name, "$", cov[cov.to.var.list==j], sep=""), collapse=",") command <- paste(command, command2, sep="") first.var <- 0 } } command <- paste(command, ")", sep = "") cov.matrix <- eval(parse(text = command)) command <- paste("with(", dataframe.name, ", crr(", call[2], ", ", call[3], ", cov.matrix, failcode=", call[5], ", cencode=", call[6], ", na.action=na.omit))", sep = "") crr2 <- eval(parse(text = command)) newAIC[i] <- crrAIC(crr2, BIC) } else { newAIC[i] <- ifelse(BIC==0, -2 * crr$loglik.null, -2 * crr$loglik.null) } in.model[i] <- 1 } } action[length(var.list)+1] <- "<none>" target[length(var.list)+1] <- "" newAIC[length(var.list)+1] <- currentAIC res <- cbind(action, target, signif(newAIC, digits=7)) res <- data.frame(res[order(newAIC),]) colnames(res) <- gettextRcmdr( c("action", "variable", method)) print(res) min <- min(newAIC) if(currentAIC <= min){ flag <- 1 } else { change.var <- which(newAIC==min) currentAIC <- min if (in.model[change.var]==1){ in.model[change.var] <- 0 cat("\n", gettextRcmdr( "-----Variable"), " ", var.list[change.var], " ", gettextRcmdr( "removed from the model."), "(", method, "=", newAIC[change.var], ")\n\n", sep = "") } else { in.model[change.var] <- 1 cat("\n", gettextRcmdr( "-----Variable"), " ", var.list[change.var], " ", gettextRcmdr( "removed from the model."), "(", method, "=", newAIC[change.var], ")\n\n", sep = "") } cat(gettextRcmdr( "Next model:"), " ", paste(var.list[in.model==1], collapse=" + "), "\n", sep="") cat(method, " = ", currentAIC, "\n\n", sep="") } } #final model if (sum(in.model) == 0) { cat("\n", gettextRcmdr( "-----All variables were removed from the model."), "\n\n", sep = "") } else { command <- "cbind(" first.var <- 1 final.cov <- NULL for (j in 1:length(var.list)){ if (in.model[j]==1){ if (first.var==0){ command <- paste(command, ",", sep="") } final.cov <- c(final.cov, cov[cov.to.var.list==j]) command2 <- paste(paste(dataframe.name, "$", cov[cov.to.var.list==j], sep=""), collapse=",") command <- paste(command, command2, sep="") first.var <- 0 } } command <- paste(command, ")", sep = "") cov.matrix <- eval(parse(text = command)) command <- paste("with(", dataframe.name, ", crr(", call[2], ", ", call[3], ", cov.matrix, failcode=", call[5], ", cencode=", call[6], ", na.action=na.omit))", sep = "") crr <- eval(parse(text = command)) res <- summary(crr) ncov <- length(cov.matrix[1,]) if (ncov > 0) { if (ncov == 1) { crr.table <- signif(cbind(t(res$conf.int[, c(1, 3, 4)]), res$coef[, 5]), digits = 4) } else { crr.table <- signif(cbind(res$conf.int[, c(1, 3, 4)], res$coef[, 5]), digits = 4) } # rownames(crr.table) <- cov[in.model[cov.to.var.list]==1] rownames(crr.table) <- final.cov colnames(crr.table) <- gettextRcmdr( c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")) cat("\n", gettextRcmdr( "-----Final model"), "\n\n", sep = "") print(crr.table) if (waldtest == 1) waldtest.crr(crr, rownames(crr.table)) } } } crrAIC <- function(crr, BIC=0){ AIC <- ifelse(BIC==0, -2 * crr$loglik + 2 * length(crr$coef), -2 * crr$loglik + log(crr$n) * length(crr$coef)) return(AIC) } waldtest <- function (cox){ # This function can be used not only for cox but also for lm and glm. res <- summary(cox) reslist <- rownames(res$coefficients) dum <- NA fac <- NA k <- 1 for (i in 1:length(reslist)){ if (regexpr(".Dummy.", reslist[i])>0) { if(k==1){ dum[k] <- substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])-1) k <- k + 1 } else if(substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])-1)!=dum[k-1]){ dum[k] <- substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])-1) k <- k + 1 } } } k <- 1 for (i in 1:length(reslist)){ for (j in 1:nchar(reslist[i])){ if (substring(reslist[i], j, j)=="["){ if(k==1){ fac[k] <- substring(reslist[i], 1, j-1) k <- k + 1 next } else if (substring(reslist[i], 1, j-1)!=fac[k-1]){ fac[k] <- substring(reslist[i], 1, j-1) k <- k + 1 next } else { next } } } } dum <- levels(factor(dum)) fac <- levels(factor(fac)) if(length(dum)>0){ for(i in 1:length(dum)){ terms <- which(substring(rownames(res$coefficients), 1, nchar(dum[i]))==dum[i]) if (length(terms)>=2){ wald <- wald.test(vcov(cox), cox$coef, terms) cat(gettextRcmdr("\nOverall p value for"), dum[i], ": ", wald[[6]][[1]][3], "\n") } } } if(length(fac)>0){ for(i in 1:length(fac)){ terms <- which(substring(rownames(res$coefficients), 1, nchar(fac[i]))==fac[i]) if (length(terms)>=2){ wald <- wald.test(vcov(cox), cox$coef, terms) cat(gettextRcmdr("\nOverall p value for"), fac[i], ": ", wald[[6]][[1]][3], "\n") } } } } waldtest.crr <- function (crr, cov){ reslist <- cov dum <- NA fac <- NA k <- 1 for (i in 1:length(reslist)){ if (regexpr(".Dummy.", reslist[i])>0) { if(k==1){ dum[k] <- substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])-1) k <- k + 1 } else if(substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])-1)!=dum[k-1]){ dum[k] <- substring(reslist[i], 1, regexpr(".Dummy.", reslist[i])-1) k <- k + 1 } } } dum <- levels(factor(dum)) if(length(dum)>0){ for(i in 1:length(dum)){ terms <- which(substring(cov, 1, nchar(dum[i]))==dum[i]) if (length(terms)>=2){ wald <- wald.test(crr$var, crr$coef, terms) cat(gettextRcmdr("\nOverall p value for"), dum[i], ": ", wald[[6]][[1]][3], "\n") } } } } logrank.trend <- function(survdiff.res, W = 1:length(survdiff.res[[1]])){ #Calculation method from http://www.mas.ncl.ac.uk/~nmf16/teaching/mas3311/handout4.pdf, Newcastle University #consistent with the results by MedCalc software # W = score for each group group.names <- survdiff.res[[1]] O <- survdiff.res$obs E <- survdiff.res$exp V <- survdiff.res$var Wupperbar <- sum (W * E) / sum(E) WOE <- W * (O - E) UT <- sum(WOE) VT <- sum((W - Wupperbar)^2*E) WT <- UT^2 / VT P <- pchisq(WT, df=1, lower.tail=FALSE) res <- data.frame(c(formatC(WT, format="g", digits=3), formatC(1, format="d"), formatC(P, format="g", digits=2))) colnames(res) <- gettextRcmdr("Logrank trend test") rownames(res) <- gettextRcmdr(c("Chi square", "DF", "p-value")) return(res) } stackcuminc <- function(timetoevent, event, xlim=NULL, ylim=c(0,1), xlab=NULL, ylab=NULL, atrisk=1, ypercent=0, main="", xaxp=NULL){ ##Enabled the use of xaxp option, Oct 8, 2020 num <- length(levels(factor(event))) max <- max(timetoevent, na.rm=TRUE) if(min(event, na.rm=TRUE)==0){ #for censored events censor <- 1 num <- num-1 #Type of event will be num-1 } else { censor <- 0 } if(num==0)stop("No event") if (atrisk==1){ doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + 1 + 0.5") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") } if (ypercent==0){ yscale <- 1 } else { yscale <- 100 # ylim=ylim * 100 #deleted according to the change in survival 3.1-8 } if (ypercent==1){ ylab <- paste(ylab, " (%)", sep="") } if(num <= 1){ #Error occurs when there is only one event type observed ci <- survfit(Surv(timetoevent, event>0)~1, na.action=na.omit) }else{ # ci <- survfit(Surv(timetoevent, event>0)~1, na.action=na.omit, etype=event) #If there are no censoring, an event with a smallest event number will be #treated as censoring in the new survival package. To avoid this, make the smallest #level as "0". if(censor==0){ event <- factor(event, levels=c("0", levels(as.factor(event)))) }else{ event <- as.factor(event) } ci <- survfit(Surv(timetoevent, event, type="mstate")~1, na.action=na.omit) } if(is.null(ci$surv)){ ci$surv <- 1-ci$pstate } time <- rep(ci$time[1], 2) for (i in 2:length(ci$time)){ time <- c(time, rep(ci$time[i], 2)) } time <- c(time, rep(max, 2)) if (is.null(ci$surv)) ci$surv <- 1-ci$prev #added from EZR ver 1.11 ci$surv <- 1-ci$surv y <- rep(0, num) for (i in 1:length(ci$time)){ next.y <- NULL for(j in 1:num){ if (num==1){ next.y[j] <- sum(ci$surv[i]) } else { next.y[j] <- sum(ci$surv[i, (j+1):(num+1)]) #changed accoriding to the survival ver. 3.1-8 } } y <- rbind(y, next.y) y <- rbind(y, next.y) } y <- rbind(y, rep(0, num)) for(i in 1:num){ if (i==1) { if(is.null(xaxp)){ plot(ci, fun="event", col=0, bty="l", xlim=xlim, ylim=ylim, yscale=yscale, xlab=xlab, ylab=ylab, main=main) } else { plot(ci, fun="event", col=0, bty="l", xlim=xlim, ylim=ylim, yscale=yscale, xlab=xlab, ylab=ylab, main=main, xaxp=xaxp) } if(atrisk==1){ if(is.null(xaxp)){ xticks <- axTicks(1) } else { xticks <- axTicks(1, axp=xaxp) } # n.atrisk <- nrisk(ci, xticks) if(num==1){n.atrisk <- nrisk(ci, xticks)} else {n.atrisk <- nrisk(ci[,1], xticks)} #changed accoriding to the survival ver. 3.1-8 axis(1, at = xticks, labels = n.atrisk, line = 3, tick = FALSE) title(xlab = "Number at risk", line = 3, adj = 0) } } if (num==1){ polygon(c(0, time, max), c(0, y, 0), col=gray(1-0.1*i)) }else{ polygon(c(0, time, max), c(0, y[ ,i], 0), col=gray(1-0.1*i)) } } legend("topleft", legend=levels(factor(event))[(censor+1):(censor+num)], col=gray(seq(0.9, 1-0.1*num, by=-0.1)), bty="n", lty=1, lwd=10) } CurrentSurvival <- function(Dataset, StartPoint, EventOnOff, follow.up, event, strat=NULL, conf.int=FALSE, com.est=FALSE, intervals=365, col=0, cci=0, pvals=FALSE) { if (is.null(StartPoint) | is.null(EventOnOff) | is.null(follow.up) | is.null(event)){ return() } CLFSdata <- data.frame(StartPoint=Dataset[,colnames(Dataset)==StartPoint]) for (i in 1:length(EventOnOff)){ CLFSdata <- cbind(CLFSdata, Dataset[,colnames(Dataset)==EventOnOff[i]]) } CLFSdata$follow.up <- Dataset[,colnames(Dataset)==follow.up] CLFSdata$event <- Dataset[,colnames(Dataset)==event] if (!is.null(strat)){ CLFSdata$strat <- Dataset[,colnames(Dataset)==strat] strat <- TRUE } else { strat <- FALSE } ColumnsPerGroup <- ifelse(com.est==TRUE, 6, 3) if(cci==0){ if (strat==TRUE){ res <- clfs(CLFSdata, strat=TRUE, fig=FALSE, conf.int=TRUE, com.est=com.est, pvals=pvals) } else { res <- clfs(CLFSdata, strat=FALSE, fig=FALSE, conf.int=TRUE, com.est=com.est) } ###clfs function does not allow setting plot option (e.g. line colour, width and type) and thus the following scripts are required maxx <- max(res$pest.day[,1]) # maximum follow-up time maxx.x <- ceiling(maxx/100)*100 plot(0,1,pch='.',cex=0.01,xlim=c(0,maxx),ylim=c(0,1),axes=FALSE, xlab="Time", ylab="Probability") # plot initialization axis(2, at=seq(0,1,0.2)) # setting of points where tick-marks are # axis(1,at=seq(from=0, to=maxx.x, length.out=11),labels=seq(0, maxx.x, length.out=11)) axis(1,at=seq(from=0, to=maxx.x, by=intervals),labels=seq(0, maxx.x, by=intervals)) groups <- length(colnames(res$no.risk))-1 if(com.est==TRUE) groups <- groups/2 x <- 0:maxx for(i in 1:groups){ if (col==1){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+3],type="S",col=i, lwd=2) if(conf.int==TRUE){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+2],type="S",col=i, lty=2, lwd=2) lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+4],type="S",col=i, lty=2, lwd=2) } if(com.est==TRUE){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+6],type="S",col=i, lwd=1) } } else { lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+3],type="S",lty=i,lwd=2) if(conf.int==TRUE){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+2],type="S",lty=i, lwd=1) lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+4],type="S",lty=i, lwd=1) } if(com.est==TRUE){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+6],type="S",lty=i, lwd=1) } } } if (groups>1){ group.names <- levels(as.factor(CLFSdata$strat)) if (col==1){ legend("bottomright", legend=group.names, col=1:groups, lty=1, bty="n", cex=0.9) } else { legend("bottomright", legend=group.names, lwd=2, lty=1:groups, bty="n", cex=0.9) } } res } else { if (strat==TRUE){ res <- cci(CLFSdata, strat=TRUE, fig=FALSE, conf.int=TRUE, com.est=com.est, pvals=pvals) } else { res <- cci(CLFSdata, strat=FALSE, fig=FALSE, conf.int=TRUE, com.est=com.est) } ###clfs function does not allow setting plot option (e.g. line colour, width and type) and thus the following scripts are required maxx <- max(res$pest.day[,1]) # maximum follow-up time maxx.x <- ceiling(maxx/100)*100 plot(0,0,pch='.',cex=0.01,xlim=c(0,maxx),ylim=c(0,1),axes=FALSE, xlab="Time", ylab="Probability") # plot initialization axis(2, at=seq(0,1,0.2)) # setting of points where tick-marks are # axis(1,at=seq(from=0, to=maxx.x, length.out=11),labels=seq(0, maxx.x, length.out=11)) axis(1,at=seq(from=0, to=maxx.x, by=intervals),labels=seq(0, maxx.x, by=intervals)) groups <- length(colnames(res$no.risk))-1 if(com.est==TRUE) groups <- groups/2 x <- 0:maxx for(i in 1:groups){ if (col==1){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+3],type="S",col=i, lwd=2) if(conf.int==TRUE){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+2],type="S",col=i, lty=2, lwd=2) lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+4],type="S",col=i, lty=2, lwd=2) } if(com.est==TRUE){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+6],type="S",col=i, lwd=1) } } else { lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+3],type="S",lty=i,lwd=2) if(conf.int==TRUE){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+2],type="S",lty=i, lwd=1) lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+4],type="S",lty=i, lwd=1) } if(com.est==TRUE){ lines(x, res$pest.day[,ColumnsPerGroup*(i-1)+6],type="S",lty=i, lwd=2) } } } if (groups>1){ group.names <- levels(as.factor(CLFSdata$strat)) if (col==1){ legend("bottomright", legend=group.names, col=1:groups, lty=1, bty="n", cex=0.9) } else { legend("bottomright", legend=group.names, lwd=2, lty=1:groups, bty="n", cex=0.9) } } res } } IPTW.ATE <- function(GLM) { group <- colnames(GLM$model)[1] factors <- colnames(GLM$model)[2:length(colnames(GLM$model))] classes <- attr(GLM$terms, "dataClasses")[2:length(attr(GLM$terms, "dataClasses"))] command <- paste("tab <- table(GLM$data$", group, ")", sep="") tab <- eval(parse(text=command)) p <- tab[2] / (tab[1] + tab[2]) p.score <- predict(GLM, type="response") command <- paste("weight.ATE <- ifelse(GLM$data$", group, "==levels(as.factor(GLM$data$", group, "))[1], (1-p)/(1-p.score), p/p.score)", sep="") eval(parse(text=command)) for (i in 1:length(factors)){ command <- paste("lev <- length(levels(as.factor(GLM$data$", factors[i], ")))", sep="") eval(parse(text=command)) command <- paste("num <- is.numeric(GLM$data$", factors[i], ")", sep="") eval(parse(text=command)) if (lev==2){ command <- paste("st.diff.binom.w(GLM$data$", factors[i], ", weight.ATE, GLM$data$", group, ")", sep="") } else if (classes[i]=="factor") { command <- paste("st.diff.multinom.w(GLM$data$", factors[i], ", weight.ATE, GLM$data$", group, ")", sep="") } else { command <- paste("st.diff.numeric.w(GLM$data$", factors[i], ", weight.ATE, GLM$data$", group, ")", sep="") } res <- eval(parse(text=command)) cat(paste(factors[i], ", ", res, "\n", sep="")) } return(weight.ATE) } propensity.plot <- function(group, p.score, side=1, weights=NULL){ ##modified from https://rpubs.com/kaz_yos/ps-rhc if(side==1) { y.val <- 1 ylim <- 0 } else { y.val <- -1 ylim <- -1 } select <- complete.cases(group, p.score, weights) group <- group[select] p.score <- p.score[select] if(!is.null(weights))weights <- weights[select] group.names <- levels(as.factor(group)) if(levels(as.factor(group))[1]!="0" | levels(as.factor(group))[2]!="1") group <- ifelse(group==levels(as.factor(group))[1], 0, 1) if(is.null(weights)) { weights <- rep(1/length(group), length(group)) PlotAll <- suppressWarnings(density(x=p.score, weights=weights)) plot(x=PlotAll$x, y=PlotAll$y, type="l", col="#999999", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), xlab="Propensity score", ylab="Distribution") if (side!=1){ par(new=T) plot(x=PlotAll$x, y=y.val*PlotAll$y, type="l", col="#999999", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), xlab="", ylab="") if (side!=1) abline(h=0, lty=2) } PlotGroup0 <- suppressWarnings(density(x=p.score[group==0], weights=weights[group==0])) par(new=T) plot(x=PlotGroup0$x, PlotGroup0$y, col="#D55E00", type="l", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), xlab="", ylab="", col.axis=0) PlotGroup1 <- suppressWarnings(density(x=p.score[group==1], weights=weights[group==1])) par(new=T) plot(x=PlotGroup1$x, y=y.val*PlotGroup1$y, col="#0072B2", type="l", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), xlab="", ylab="", col.axis=0) legend("topright", group.names, col=c("#D55E00", "#0072B2"), lty=1, lwd=1, box.lty=0) } else { noweights <- rep(1/length(group), length(group)) PlotAll <- suppressWarnings(density(x=p.score, weights=noweights)) plot(x=PlotAll$x, y=PlotAll$y, type="l", col="#999999", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), xlab="Propensity score", ylab="Distribution") # legend("topright", "Thin line : before weighting\nThick line : after weighting", box.lty=0) legend("topright", c(paste(group.names, "before IPTW", sep=" : "), paste(group.names, "after IPTW", sep=" : ")), col=rep(c("#D55E00", "#0072B2"), 2), lty=1, lwd=c(1,1,2,2), box.lty=0) if (side!=1){ par(new=T) plot(x=PlotAll$x, y=y.val*PlotAll$y, type="l", col="#999999", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), xlab="", ylab="", col.axis=0) if (side!=1) abline(h=0, lty=2) } par(new=T) PlotGroup0 <- suppressWarnings(density(x=p.score[group==0], weights=weights[group==0]/length(group))) PlotGroup1 <- suppressWarnings(density(x=p.score[group==1], weights=weights[group==1]/length(group))) plot(x=PlotGroup0$x, y=PlotGroup0$y, col="#D55E00", type="l", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), lwd=2, xlab="", ylab="", col.axis=0) par(new=T) plot(x=PlotGroup1$x, y=y.val*PlotGroup1$y, col="#0072B2", type="l", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), lwd=2, xlab="", ylab="", col.axis=0) PlotGroup0nw <- suppressWarnings(density(x=p.score[group==0], weights=noweights[group==0])) par(new=T) plot(x=PlotGroup0nw$x, y=PlotGroup0nw$y, col="#D55E00", type="l", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), xlab="", ylab="", col.axis=0) PlotGroup1nw <- suppressWarnings(density(x=p.score[group==1], weights=noweights[group==1])) par(new=T) plot(x=PlotGroup1nw$x, y=y.val*PlotGroup1nw$y, col="#0072B2", type="l", xlim=c(-0.2,1.2), ylim=c(ylim*max(PlotAll$y),max(PlotAll$y)), xlab="", ylab="", col.axis=0) } } st.diff.categor <- function(factor, group){ if(length(levels(as.factor(group)))!=2){ return("The number of groups must be 2.") } if(length(levels(as.factor(factor)))>2){ #modified from stddiff.category() in stddiff package. nr <- length(levels(factor)) tbl <- table(factor, group) prop <- prop.table(tbl, 2) t <- prop[-1, 2] c <- prop[-1, 1] k <- nr - 1 l <- k s <- matrix(rep(0, k * l), ncol = k) for (ii in 1:k) { for (j in 1:l) { if (ii == j) { s[ii, j] <- 0.5 * (t[ii] * (1 - t[ii]) + c[ii] * (1 - c[ii])) } if (ii != j) { s[ii, j] <- -0.5 * (t[ii] * t[j] + c[ii] * c[j]) } } } e <- rep(1, k) e <- diag(e) s <- solve(s, e) tc1 <- t - c tc2 <- t - c stddiff <- sqrt(t(tc1) %*% s %*% tc2) text <- "" prop <- round(prop, digits=3) for(i in 1:nr){ text <- paste(text, "p", i, "1=", prop[i,1], ", p", i, "2=", prop[i,2], ", ", sep="") } text <- paste(text, "Standardized difference=", round(stddiff, digits=3), sep="") return(text) } else { tab <- table(factor, group) p1 <- tab[2,1]/(tab[1,1]+tab[2,1]) p2 <- tab[2,2]/(tab[1,2]+tab[2,2]) if(p1==p2){ d <- 0 } else { d <- abs(p1-p2) / sqrt((p1*(1-p1)+p2*(1-p2))/2) } return(paste("p1=", round(p1, digits=3), ", p2=", round(p2, digits=3), ", Standardized difference=", round(d, digits=3), sep="")) } } st.diff.binom <- function(factor, group){ if(length(levels(as.factor(factor)))!=2){ return("This function can be used for factors with two levels.") } else { tab <- table(factor, group) p1 <- tab[2,1]/(tab[1,1]+tab[2,1]) p2 <- tab[2,2]/(tab[1,2]+tab[2,2]) if(p1==p2){ d <- 0 } else { d <- abs(p1-p2) / sqrt((p1*(1-p1)+p2*(1-p2))/2) } return(paste("p1=", round(p1, digits=3), ", p2=", round(p2, digits=3), ", Standardized difference=", round(d, digits=3), sep="")) } } st.diff.multinom <- function(factor, group){ #modified from stddiff.category() in stddiff package. nr <- length(levels(factor)) tbl <- table(factor, group) prop <- prop.table(tbl, 2) t <- prop[-1, 2] c <- prop[-1, 1] k <- nr - 1 l <- k s <- matrix(rep(0, k * l), ncol = k) for (ii in 1:k) { for (j in 1:l) { if (ii == j) { s[ii, j] <- 0.5 * (t[ii] * (1 - t[ii]) + c[ii] * (1 - c[ii])) } if (ii != j) { s[ii, j] <- -0.5 * (t[ii] * t[j] + c[ii] * c[j]) } } } e <- rep(1, k) e <- diag(e) s <- solve(s, e) tc1 <- t - c tc2 <- t - c stddiff <- sqrt(t(tc1) %*% s %*% tc2) text <- "" prop <- round(prop, digits=3) for(i in 1:nr){ text <- paste(text, "p", i, "1=", prop[i,1], ", p", i, "2=", prop[i,2], ", ", sep="") } text <- paste(text, "Standardized difference=", round(stddiff, digits=3), sep="") return(text) } st.diff.numeric <- function(numeric, group){ res <- numSummary(numeric, groups=group, statistics=c("mean", "sd")) av1 <- res$table[1,1] av2 <- res$table[2,1] sd1 <- res$table[1,2] sd2 <- res$table[2,2] d <- abs(av1-av2) / sqrt((sd1^2+sd2^2)/2) return(paste("mean1=", round(av1, digits=3), ", maen2=", round(av2, digits=3), ", Standardized difference=", round(d, digits=3), sep="")) } st.diff.binom.w <- function(factor, weight, group){ if(length(levels(as.factor(factor)))!=2){ return("This function can be used for factors with two levels.") } else { factors <- levels(as.factor(factor)) factor <- ifelse(factor==factors[1], 0, 1) groups <- levels(as.factor(group)) sum.w1 <- 0; sum.w2 <- 0 n.w1 <- 0; n.w2 <- 0 for (i in 1:length(factor)){ if (!is.na(factor[i]) & !is.na(weight[i]) & !is.na(group[i])){ if (group[i]==groups[1]){ sum.w1 <- sum.w1 + factor[i] * weight[i] n.w1 <- n.w1 + weight[i] } else { sum.w2 <- sum.w2 + factor[i] * weight[i] n.w2 <- n.w2 + weight[i] } } } p1 <- sum.w1 / n.w1 p2 <- sum.w2 / n.w2 if(p1==p2){ d <- 0 } else { d <- abs(p1-p2) / sqrt((p1*(1-p1)+p2*(1-p2))/2) } return(paste("p1=", round(p1, digits=3), ", p2=", round(p2, digits=3), ", Standardized difference=", round(d, digits=3), sep="")) } } st.diff.multinom.w <- function(factor, weight, group){ #modified from stddiff.category() in stddiff package. nr <- length(levels(factor)) tbl <- table(factor, group) prop <- prop.table(tbl, 2) groups <- levels(as.factor(group)) n.w1 <- sum(weight[group==groups[1]], na.rm=T) n.w2 <- sum(weight[group==groups[2]], na.rm=T) for(f in 1:nr){ sum.w1 <- 0; sum.w2 <- 0 for (i in 1:length(factor)){ if (!is.na(factor[i]) & !is.na(weight[i]) & !is.na(group[i])){ if (group[i]==groups[1] & factor[i]==levels(factor)[f]){ sum.w1 <- sum.w1 + weight[i] } if (group[i]==groups[2] & factor[i]==levels(factor)[f]){ sum.w2 <- sum.w2 + weight[i] } } } prop[f,1] <- sum.w1 / n.w1 prop[f,2] <- sum.w2 / n.w2 } t <- prop[-1, 2] c <- prop[-1, 1] k <- nr - 1 l <- k s <- matrix(rep(0, k * l), ncol = k) for (ii in 1:k) { for (j in 1:l) { if (ii == j) { s[ii, j] <- 0.5 * (t[ii] * (1 - t[ii]) + c[ii] * (1 - c[ii])) } if (ii != j) { s[ii, j] <- -0.5 * (t[ii] * t[j] + c[ii] * c[j]) } } } e <- rep(1, k) e <- diag(e) s <- solve(s, e) tc1 <- t - c tc2 <- t - c stddiff <- sqrt(t(tc1) %*% s %*% tc2) text <- "" prop <- round(prop, digits=3) for(i in 1:nr){ text <- paste(text, "p", i, "1=", prop[i,1], ", p", i, "2=", prop[i,2], ", ", sep="") } text <- paste(text, "Standardized difference=", round(stddiff, digits=3), sep="") return(text) } st.diff.numeric.w <- function(numeric, weight, group){ groups <- levels(as.factor(group)) sum.w1 <- 0; sum.w2 <- 0 n.w1 <- 0; n.w2<- 0 sigma.sq.w1 <- 0; sigma.sq.w2 <- 0 for (i in 1:length(numeric)){ if (!is.na(numeric[i]) & !is.na(weight[i]) & !is.na(group[i])){ if (group[i]==groups[1]){ sum.w1 <- sum.w1 + numeric[i]*weight[i] n.w1 <- n.w1 + weight[i] sigma.sq.w1 <- sigma.sq.w1 + weight[i]^2 } else { sum.w2 <- sum.w2 + numeric[i]*weight[i] n.w2 <- n.w2+ weight[i] sigma.sq.w2 <- sigma.sq.w2 + weight[i]^2 } } } av.w1 <- sum.w1 / n.w1 av.w2 <- sum.w2 / n.w2 tmp1 <- 0; tmp2 <- 0 for (i in 1:length(numeric)){ if (!is.na(numeric[i]) & !is.na(weight[i]) & !is.na(group[i])){ if (group[i]==groups[1]){ tmp1 <- tmp1 + weight[i]*((numeric[i]-av.w1)^2) } else { tmp2 <- tmp2 + weight[i]*((numeric[i]-av.w2)^2) } } } sd1.sq <- (n.w1 / (n.w1^2 - sigma.sq.w1)) * tmp1 sd2.sq <- (n.w2 / (n.w2^2 - sigma.sq.w2)) * tmp2 d <- abs(av.w1-av.w2) / sqrt((sd1.sq+sd2.sq)/2) return(paste("mean1=", round(av.w1, digits=3), ", maen2=", round(av.w2, digits=3), ", Standardized difference=", round(d, digits=3), sep="")) } st.diff.categor.w <- function(factor, weight, group){ if(length(levels(as.factor(group)))!=2){ return("The number of groups must be 2.") } if(length(levels(as.factor(factor)))!=2){ #modified from stddiff.category() in stddiff package. nr <- length(levels(factor)) tbl <- table(factor, group) prop <- prop.table(tbl, 2) groups <- levels(as.factor(group)) n.w1 <- sum(weight[group==groups[1]], na.rm=T) n.w2 <- sum(weight[group==groups[2]], na.rm=T) for(f in 1:nr){ sum.w1 <- 0; sum.w2 <- 0 for (i in 1:length(factor)){ if (!is.na(factor[i]) & !is.na(weight[i]) & !is.na(group[i])){ if (group[i]==groups[1] & factor[i]==levels(factor)[f]){ sum.w1 <- sum.w1 + weight[i] } if (group[i]==groups[2] & factor[i]==levels(factor)[f]){ sum.w2 <- sum.w2 + weight[i] } } } prop[f,1] <- sum.w1 / n.w1 prop[f,2] <- sum.w2 / n.w2 } t <- prop[-1, 2] c <- prop[-1, 1] k <- nr - 1 l <- k s <- matrix(rep(0, k * l), ncol = k) for (ii in 1:k) { for (j in 1:l) { if (ii == j) { s[ii, j] <- 0.5 * (t[ii] * (1 - t[ii]) + c[ii] * (1 - c[ii])) } if (ii != j) { s[ii, j] <- -0.5 * (t[ii] * t[j] + c[ii] * c[j]) } } } e <- rep(1, k) e <- diag(e) s <- solve(s, e) tc1 <- t - c tc2 <- t - c stddiff <- sqrt(t(tc1) %*% s %*% tc2) text <- "" prop <- round(prop, digits=3) for(i in 1:nr){ text <- paste(text, "p", i, "1=", prop[i,1], ", p", i, "2=", prop[i,2], ", ", sep="") } text <- paste(text, "Standardized difference=", round(stddiff, digits=3), sep="") return(text) } else { factors <- levels(as.factor(factor)) factor <- ifelse(factor==factors[1], 0, 1) groups <- levels(as.factor(group)) sum.w1 <- 0; sum.w2 <- 0 n.w1 <- 0; n.w2 <- 0 for (i in 1:length(factor)){ if (!is.na(factor[i]) & !is.na(weight[i]) & !is.na(group[i])){ if (group[i]==groups[1]){ sum.w1 <- sum.w1 + factor[i] * weight[i] n.w1 <- n.w1 + weight[i] } else { sum.w2 <- sum.w2 + factor[i] * weight[i] n.w2 <- n.w2 + weight[i] } } } p1 <- sum.w1 / n.w1 p2 <- sum.w2 / n.w2 if(p1==p2){ d <- 0 } else { d <- abs(p1-p2) / sqrt((p1*(1-p1)+p2*(1-p2))/2) } return(paste("p1=", round(p1, digits=3), ", p2=", round(p2, digits=3), ", Standardized difference=", round(d, digits=3), sep="")) } } var2 <- function(x){ var(x, na.rm=TRUE) * (length(which(!is.na(x)))-1) / length(which(!is.na(x))) } sd2 <- function(x){ sqrt(var2(x)) } numSummary2 <- function (data, statistics = c("mean", "u.sd", "p.sd", "u.var", "p.var", "se(mean)", "IQR", "quantiles", "cv", "skewness", "kurtosis"), type = c("2", "1", "3"), quantiles = c(0, 0.25, 0.5, 0.75, 1), groups){ u.sd <- function(x, type, ...) { #Unbiased standard deviation apply(as.matrix(x), 2, stats::sd, na.rm = TRUE) } u.var <- function(x, type, ...) { apply(as.matrix(x), 2, stats::var, na.rm = TRUE) } p.var <- function(x, ...){ apply(as.matrix(x), 2, var2) # u.var(x) * (length(which(!is.na(x)))-1) / length(which(!is.na(x))) } p.sd <- function(x, ...){ #Population standard deviation apply(as.matrix(x), 2, sd2) # sqrt(p.var(x)) } IQR <- function(x, type, ...) { apply(as.matrix(x), 2, stats::IQR, na.rm = TRUE) } std.err.mean <- function(x, ...) { x <- as.matrix(x) sd <- sd(x) n <- colSums(!is.na(x)) sd/sqrt(n) } cv <- function(x, ...) { x <- as.matrix(x) mean <- colMeans(x, na.rm = TRUE) sd <- sd(x) if (any(x <= 0, na.rm = TRUE)) warning("not all values are positive") cv <- sd/mean cv[mean <= 0] <- NA cv } skewness <- function(x, type, ...) { if (is.vector(x)) # return(e1071::skewness(x, type = type, na.rm = TRUE)) return(skewness(x, type = type, na.rm = TRUE)) apply(x, 2, skewness, type = type) } kurtosis <- function(x, type, ...) { if (is.vector(x)) # return(e1071::kurtosis(x, type = type, na.rm = TRUE)) return(kurtosis(x, type = type, na.rm = TRUE)) apply(x, 2, kurtosis, type = type) } data <- as.data.frame(data) if (!missing(groups)) { groups <- as.factor(groups) counts <- table(groups) if (any(counts == 0)) { levels <- levels(groups) warning("the following groups are empty: ", paste(levels[counts == 0], collapse = ", ")) groups <- factor(groups, levels = levels[counts != 0]) } } variables <- names(data) if (missing(statistics)) statistics <- c("mean", "sd", "quantiles", "IQR") statistics <- match.arg(statistics, c("mean", "u.sd", "u.var", "p.sd", "p.var", "se(mean)", "IQR", "quantiles", "cv", "skewness", "kurtosis"), several.ok = TRUE) type <- match.arg(type) type <- as.numeric(type) ngroups <- if (missing(groups)) 1 else length(grps <- levels(groups)) quantiles <- if ("quantiles" %in% statistics) quantiles else NULL quants <- if (length(quantiles) >= 1) paste(100 * quantiles, "%", sep = "") else NULL nquants <- length(quants) stats <- c(c("mean", "u.sd", "u.var", "p.sd", "p.var", "se(mean)", "IQR", "cv", "skewness", "kurtosis")[c("mean", "u.sd", "u.var", "p.sd", "p.var", "se(mean)", "IQR", "cv", "skewness", "kurtosis") %in% statistics], quants) nstats <- length(stats) nvars <- length(variables) result <- list() if ((ngroups == 1) && (nvars == 1) && (length(statistics) == 1)) { if (statistics == "quantiles") table <- quantile(data[, variables], probs = quantiles, na.rm = TRUE) else { stats <- statistics stats[stats == "se(mean)"] <- "std.err.mean" table <- do.call(stats, list(x = data[, variables], na.rm = TRUE, type = type)) names(table) <- statistics } NAs <- sum(is.na(data[, variables])) n <- nrow(data) - NAs result$type <- 1 } else if ((ngroups > 1) && (nvars == 1) && (length(statistics) == 1)) { if (statistics == "quantiles") { table <- matrix(unlist(tapply(data[, variables], groups, quantile, probs = quantiles, na.rm = TRUE)), ngroups, nquants, byrow = TRUE) rownames(table) <- grps colnames(table) <- quants } else table <- tapply(data[, variables], groups, statistics, na.rm = TRUE, type = type) NAs <- tapply(data[, variables], groups, function(x) sum(is.na(x))) n <- table(groups) - NAs result$type <- 2 } else if ((ngroups == 1)) { X <- as.matrix(data[, variables]) table <- matrix(0, nvars, nstats) rownames(table) <- if (length(variables) > 1) variables else "" colnames(table) <- stats if ("mean" %in% stats) table[, "mean"] <- colMeans(X, na.rm = TRUE) if ("u.sd" %in% stats) table[, "u.sd"] <- u.sd(X) #Sample standard deviation if ("u.var" %in% stats) table[, "u.var"] <- u.var(X) if ("p.sd" %in% stats) table[, "p.sd"] <- p.sd(X) #Population standard deviation if ("p.var" %in% stats) table[, "p.var"] <- p.var(X) if ("se(mean)" %in% stats) table[, "se(mean)"] <- std.err.mean(X) if ("IQR" %in% stats) table[, "IQR"] <- IQR(X) if ("cv" %in% stats) table[, "cv"] <- cv(X) if ("skewness" %in% statistics) table[, "skewness"] <- skewness(X, type = type) if ("kurtosis" %in% statistics) table[, "kurtosis"] <- kurtosis(X, type = type) if ("quantiles" %in% statistics) { table[, quants] <- t(apply(data[, variables, drop = FALSE], 2, quantile, probs = quantiles, na.rm = TRUE)) } NAs <- colSums(is.na(data[, variables, drop = FALSE])) n <- nrow(data) - NAs result$type <- 3 } else { table <- array(0, c(ngroups, nstats, nvars), dimnames = list(Group = grps, Statistic = stats, Variable = variables)) NAs <- matrix(0, nvars, ngroups) rownames(NAs) <- variables colnames(NAs) <- grps for (variable in variables) { if ("mean" %in% stats) table[, "mean", variable] <- tapply(data[, variable], groups, mean, na.rm = TRUE) if ("u.sd" %in% stats) table[, "u.sd", variable] <- tapply(data[, variable], groups, u.sd, na.rm = TRUE) if ("u.var" %in% stats) table[, "u.var", variable] <- tapply(data[, variable], groups, u.var, na.rm = TRUE) if ("p.sd" %in% stats) table[, "p.sd", variable] <- tapply(data[, variable], groups, p.sd, na.rm = TRUE) if ("p.var" %in% stats) table[, "p.var", variable] <- tapply(data[, variable], groups, p.var, na.rm = TRUE) if ("se(mean)" %in% stats) table[, "se(mean)", variable] <- tapply(data[, variable], groups, std.err.mean, na.rm = TRUE) if ("IQR" %in% stats) table[, "IQR", variable] <- tapply(data[, variable], groups, IQR, na.rm = TRUE) if ("cv" %in% stats) table[, "cv", variable] <- tapply(data[, variable], groups, cv) if ("skewness" %in% stats) table[, "skewness", variable] <- tapply(data[, variable], groups, skewness, type = type) if ("kurtosis" %in% stats) table[, "kurtosis", variable] <- tapply(data[, variable], groups, kurtosis, type = type) if ("quantiles" %in% statistics) { res <- matrix(unlist(tapply(data[, variable], groups, quantile, probs = quantiles, na.rm = TRUE)), ngroups, nquants, byrow = TRUE) table[, quants, variable] <- res } NAs[variable, ] <- tapply(data[, variable], groups, function(x) sum(is.na(x))) } if (nstats == 1) table <- table[, 1, ] if (nvars == 1) table <- table[, , 1] n <- table(groups) n <- matrix(n, nrow = nrow(NAs), ncol = ncol(NAs), byrow = TRUE) n <- n - NAs result$type <- 4 } result$table <- table result$statistics <- statistics result$n <- n if (any(NAs > 0)) result$NAs <- NAs class(result) <- "numSummary" result } #roc.best <- function (..., roc){ # n <- length(roc[[4]]) # min.distance <- 1 # sensitivity <- roc[[4]][1] # specificity <- roc[[5]][1] # threshold <- roc[[6]][1] # for (i in 1:n){ # distance <- (1-roc[[4]][i])^2 + (1-roc[[5]][i])^2 # if (distance < min.distance){ # min.distance <- distance # sensitivity <- roc[[4]][i] # specificity <- roc[[5]][i] # threshold <- roc[[6]][i] # } # } # res <- c(threshold=threshold, specificity=specificity, sensitivity=sensitivity) # return(res) #} SampleProportionSingleArm <- function (p1, p2, alpha, power, method, continuity) { #method = 2 for two sided, 1 for one sided #from Jitsuyo SAS Seibutsu Tokei Handbook #Continuity correction method is from S-PLUS manual; binomial.sample.size() side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha/method ZA <- qnorm(1-alpha2) ZB <- qnorm(power) N <- ceiling((ZA*sqrt(p1*(1-p1))+ZB*sqrt(p2*(1-p2)))^2 / (p2-p1)^2 ) if(continuity==1){ N <- ceiling(N + (2 / abs(p2-p1))) #from S-PLUS manual } res <- data.frame(c(p1, p2, alpha, side, power, " ", gettextRcmdr("Estimated"), N)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P in the population", "Alternative P", "Alpha", " ", "Power", " ", " ", "Required sample size")) y <- seq(0.2, 1, 0.05) if(continuity==1){ plot((ZA*sqrt(p1*(1-p1))+qnorm(y)*sqrt(p2*(1-p2)))^2 / (p2-p1)^2 + (2 / abs(p2-p1)), y, ylim=c(0,1), type="l", ylab="Power", xlab="N") } else { plot((ZA*sqrt(p1*(1-p1))+qnorm(y)*sqrt(p2*(1-p2)))^2 / (p2-p1)^2, y, ylim=c(0,1), type="l", ylab="Power", xlab="N") } abline(h=power, lty=2) return(res) } PowerProportionSingleArm <- function (p1, p2, alpha, n, method, continuity) { #method = 2 for two sided, 1 for one sided #from Jitsuyo SAS Seibutsu Tokei Handbook #Continuity correction method is from S-PLUS manual; binomial.sample.size() side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha/method N <- n if(continuity==1){ N <- N - (2 / abs(p2-p1)) #from S-PLUS manual } ZA <- qnorm(1-alpha2) ZB <- (sqrt(N) * abs(p2-p1) - qnorm(1-alpha2)*sqrt(p1*(1-p1))) / sqrt(p2*(1-p2)) power <- signif(pnorm(ZB), digits=3) res <- data.frame(c(p1, p2, alpha, side, n, " ", gettextRcmdr("Estimated"), power)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P in the population", "Alternative P", "Alpha", " ", "Sample size", " ", " ", "Power")) y <- seq(0.2, 1, 0.05) if(continuity==1){ plot((ZA*sqrt(p1*(1-p1))+qnorm(y)*sqrt(p2*(1-p2)))^2 / (p2-p1)^2 + (2 / abs(p2-p1)), y, ylim=c(0,1), type="l", ylab="Power", xlab="N") } else { plot((ZA*sqrt(p1*(1-p1))+qnorm(y)*sqrt(p2*(1-p2)))^2 / (p2-p1)^2, y, ylim=c(0,1), type="l", ylab="Power", xlab="N") } # plot((ZA*sqrt(p1*(1-p1))+qnorm(y)*sqrt(p2*(1-p2)))^2 / (p2-p1)^2, y, ylim=c(0,1), type="l", ylab="Power", xlab="N") abline(v=n, lty=2) return(res) } SampleProportionCI <- function (p, delta, ci) { #From Igakuteki Kenkyuno Design alpha <- (100 - ci) / 100 ZA <- qnorm(1-alpha/2) N <- ceiling((4*ZA^2*p*(1-p)) / (delta^2)) res <- data.frame(c(p, delta, ci/100, " ", gettextRcmdr("Estimated"), N)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P", "Confidence interval", "Confidence level", " ", " ", "Required sample size")) y <- seq(delta/2, delta*2, length=20) plot((4*ZA^2*p*(1-p)) / (y^2), y, ylim=c(0,1), type="l", ylab="Confidence interval", xlab="N") abline(h=delta, lty=2) return(res) } SampleMeanCI <- function (sd, delta, ci) { #From Igakuteki Kenkyuno Design alpha <- (100 - ci) / 100 ZA <- qnorm(1-alpha/2) N <- ceiling((4*ZA^2*sd^2) / (delta^2) ) res <- data.frame(c(sd, delta, ci/100, " ", gettextRcmdr("Estimated"), N)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("Standard deviation", "Confidence interval", "Confidence level", " ", " ", "Required sample size")) y <- seq(delta/2, delta*2, length=20) plot((4*ZA^2*sd^2) / (y^2), y, ylim=c(0,delta*2.2), type="l", ylab="Delta", xlab="N") abline(h=delta, lty=2) return(res) } SamplePhaseII <- function (p1, p2, alpha, power) { ZA <- qnorm(1-alpha) ZB <- qnorm(power) N <- ceiling(((ZA*sqrt(p1*(1-p1))+ZB*sqrt(p2*(1-p2)))^2)/((p2-p1)^2)) res <- data.frame(c(p1, p2, alpha, power, " ", gettextRcmdr("Estimated"), N)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P0 (not worth studying further)", "P1 (worth studying further", "Alpha", "Power", " ", " ", "Required sample size")) return(res) } SampleMean <- function (difference, sd, alpha, power, method, r) { #method = 2 for two sided, 1 for one sided, r for group2/group1 ratio #from Jitsuyo SAS Seibutsu Tokei Handbook side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha / method ZA <- qnorm(1-alpha2) ZB <- qnorm(power) N1 <- ceiling((1+1/r)*((ZA+ZB)^2)*((sd/difference)^2)) N2 <- N1 * r res <- data.frame(c(difference, sd, alpha, side, power, r, " ", gettextRcmdr("Estimated"), N1, N2)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("Difference in means", "Standard deviation", "Alpha", " ", "Power", "N2/N1", " ", "Required sample size", "N1", "N2")) y <- seq(0.2, 1, 0.05) plot((1+1/r)*((ZA+qnorm(y))^2)*((sd/difference)^2), y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") abline(h=power, lty=2) return(res) } SampleMeanPaired <- function (difference, sd, alpha, power, method) { #method = 2 for two sided, 1 for one sided side <- ifelse(method == 1, "one.sided", "two.sided") n <- power.t.test(power=power, delta=difference, sd=sd, sig.level=alpha, alternative=side, type="paired") res <- data.frame(c(difference, sd, alpha, side, power, " ", gettextRcmdr("Estimated"), ceiling(n$n))) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("Difference in means", "Standard deviation", "Alpha", " ", "Power", " ", "Required sample size", "N")) x <- NULL y <- NULL for (i in 1:16){ y[i] <- 0.15 + i * 0.05 x[i] <- (power.t.test(power=y[i], delta=difference, sd=sd, sig.level=alpha, alternative=side, type="paired"))$n } plot(x, y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") abline(h=power, lty=2) return(res) } PowerMean <- function (difference, sd, alpha, n, method, r) { #method = 2 for two sided, 1 for one sided, r for group2/group1 ratio #from Jitsuyo SAS Seibutsu Tokei Handbook side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha / method ZA <- qnorm(1-alpha2) N <- n ZB <- difference/sd*(1/sqrt((1+1/r)/N))-ZA power <- signif(pnorm(ZB), digits=3) res <- data.frame(c(difference, sd, alpha, side, " ", N, round(N*r, 0), " ", gettextRcmdr("Estimated"), power)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("Difference in means", "Standard deviation", "Alpha", " ", "Sample size", "N1", "N2", " ", " ", "Power")) y <- seq(0.2, 1, 0.05) plot((1+1/r)*((ZA+qnorm(y))^2)*((sd/difference)^2), y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") abline(v=N, lty=2) return(res) } PowerMeanPaired <- function (difference, sd, alpha, n, method) { #method = 2 for two sided, 1 for one sided side <- ifelse(method == 1, "one.sided", "two.sided") power <- power.t.test(n=n, delta=difference, sd=sd, sig.level=alpha, alternative=side, type="paired") res <- data.frame(c(difference, sd, alpha, side, n, " ", gettextRcmdr("Estimated"), signif(power$power, digits=3))) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("Difference in means", "Standard deviation", "Alpha", " ", "Sample size", " ", " ", "Power")) x <- NULL y <- NULL for (i in 1:16){ y[i] <- 0.15 + i * 0.05 x[i] <- (power.t.test(power=y[i], delta=difference, sd=sd, sig.level=alpha, alternative=side, type="paired"))$n } plot(x, y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") abline(v=n, lty=2) return(res) } SampleProportion <- function (group1, group2, alpha, power, method, r, continuity) { #method = 2 for two sided, 1 for one sided, r for group2/group1 ratio side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha / method ZA <- qnorm(1-alpha2) ZB <- qnorm(power) WeightedMean <- (group1 + group2 * r) / (1 + r) Delta <- abs(group1-group2) Ndash <- (1/Delta^2)*(ZA*sqrt((1+r)*WeightedMean*(1-WeightedMean))+ZB*sqrt(r*group1*(1-group1)+group2*(1-group2)))^2 if(continuity==1){ N1 <- ceiling(Ndash/r + (1+r)/(r*Delta)) #from S-PLUS manual N2 <- N1 * r } else { N1 <- ceiling(Ndash/r) N2 <- N1 * r } res <- data.frame(c(group1, group2, alpha, side, power, r, " ", gettextRcmdr("Estimated"), N1, N2)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P1", "P2", "Alpha", " ", "Power", "N2/N1", " ", "Required sample size", "N1", "N2")) y <- seq(0.2, 1, 0.05) if(continuity==1){ plot((1/Delta^2)*(ZA*sqrt((1+r)*WeightedMean*(1-WeightedMean))+qnorm(y)*sqrt(r*group1*(1-group1)+group2*(1-group2)))^2 / r + (1+r)/(r*Delta), y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") } else { plot((1/Delta^2)*(ZA*sqrt((1+r)*WeightedMean*(1-WeightedMean))+qnorm(y)*sqrt(r*group1*(1-group1)+group2*(1-group2)))^2 / r, y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") } abline(h=power, lty=2) return(res) } PowerProportion <- function (group1, group2, alpha, n, method, r, continuity) { #method = 2 for two sided, 1 for one sided, r for group2/group1 ratio #from Jitsuyo SAS Seibutsu Tokei Handbook side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha / method ZA <- qnorm(1-alpha2) N <- n WeightedMean <- (group1 + group2 * r) / (1 + r) Delta <- abs(group1-group2) if(continuity==1){ Ndash <- (N-(1+r)/(r*Delta)) * r } else { Ndash <- N * r } ZB <- (sqrt(Ndash/(1/Delta^2))-ZA*sqrt((1+r)*WeightedMean*(1-WeightedMean))) / (sqrt(r*group1*(1-group1)+group2*(1-group2))) #from S-PLUS manual power <- signif(pnorm(ZB), digits=3) res <- data.frame(c(group1, group2, alpha, side, " ", N, round(N*r, 0), " ", gettextRcmdr("Estimated"), power)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P1", "P2", "Alpha", " ", "Sample size", "N1", "N2", " ", " ", "Power")) y <- seq(0.2, 1, 0.05) if(continuity==1){ plot((1/Delta^2)*(ZA*sqrt((1+r)*WeightedMean*(1-WeightedMean))+qnorm(y)*sqrt(r*group1*(1-group1)+group2*(1-group2)))^2 / r + (1+r)/(r*Delta), y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") } else{ plot((1/Delta^2)*(ZA*sqrt((1+r)*WeightedMean*(1-WeightedMean))+qnorm(y)*sqrt(r*group1*(1-group1)+group2*(1-group2)))^2 / r, y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") } abline(v=N, lty=2) return(res) } SampleProportionNonInf <- function (group1, group2, delta, alpha, power, method) { #From Musakui Waritsuke Hikaku Rinsho Shiken Page 66 side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha / method ZA <- qnorm(1-alpha2) ZB <- qnorm(power) Mean <- (group1 + group2) / 2 N <- ceiling(((ZA*sqrt(2*Mean*(1-Mean))+ZB*sqrt(group1*(1-group1)+group2*(1-group2)))^2) / ((group1-group2-delta)^2)) res <- data.frame(c(group1, group2, delta, alpha, side, power, " ", gettextRcmdr("Estimated"), N, N)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P1", "P2", "Delta", "Alpha", " ", "Power", " ", "Required sample size", "N1", "N2")) y <- seq(0.2, 1, 0.05) plot(((ZA*sqrt(2*Mean*(1-Mean))+qnorm(y)*sqrt(group1*(1-group1)+group2*(1-group2)))^2) / ((group1-group2-delta)^2), y, ylim=c(0,1), type="l", ylab="Power", xlab="N") abline(h=power, lty=2) return(res) } SampleSelectionDesign <- function (p, D, k, DesiredProb) { #https://nshi.jp/contents/js/selection/ #p: Lowest response rate among all treatments #D: Difference in response rate between the besttreatment and the other treatments #k: Number of treatment arms #n: Number of patients in each treatment arm #Prob: Probability of correctly selecting the besttreatment n <- 1 Prob <- 0 while(Prob < DesiredProb){ Prob <- pbinom(0, n, p)^(k-1) * (1 - pbinom(0, n, p+D)) for(i in 1:n){ Prob <- Prob + (pbinom(i, n, p)^(k-1) - pbinom(i-1, n, p)^(k-1)) * (1 - pbinom(i, n, p+D)) } for(i in 1:n){ tmp <- 0 for(j in 1:(k-1)){ tmp <- tmp + choose(k-1, j) * (dbinom(i, n, p)^j) * (pbinom(i-1, n, p)^(k-1-j)) / (j+1) } Prob <- Prob + tmp * dbinom(i, n, p+D) } # cat(paste("n=", n, ", prob=", Prob, "\n", sep="")) if (Prob < DesiredProb) n <- n + 1 } Prob <- signif(Prob, digits=3) res <- data.frame(c(p, D, k, DesiredProb, " ", gettextRcmdr("Estimated"), n, Prob)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("Smallest response rate", "Difference in response rate", "Number of treatment arms", "Desired Probability", " ", " ", "Required sample size per arm", "Probability estimated")) return(res) } SampleHazard <- function (enrol, observe, followup, group1, group2, alpha, power, method, ratio) { #from Jitsuyo SAS Seibutsu Tokei Handbook side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha / method ZA <- qnorm(1-alpha2) ZB <- qnorm(power) L1 <- -log(group1) / followup L2 <- -log(group2) / followup LBER <- (L1 + L2) / 2 Q1 <- 1 / (1 + ratio) Q2 <- ratio / (1 + ratio) P00 <- LBER ^2 P01 <- L1 ^ 2 P02 <- L2 ^ 2 P10 <- LBER ^ 2 / (1 - exp(-LBER * observe)) P11 <- L1 ^ 2 / ( 1 - exp(-L1 * observe)) P12 <- L2 ^ 2 / (1 - exp(-L2 * observe)) P20 <- LBER ^ 3 * followup / (LBER * observe - 1 + exp(-LBER * observe)) P21 <- L1 ^ 3 * followup / (L1 * observe - 1 + exp(-L1 * observe)) P22 <- L2 ^ 3 * followup / (L2 * observe - 1 + exp(-L2 * observe)) if (enrol>0){ P30 <- LBER ^ 2 * (1 - (exp(-LBER * (observe - enrol)) - exp(-LBER * observe)) / (LBER * enrol)) ^ (-1) P31 <- L1 ^ 2 * (1 - (exp(-L1 * (observe - enrol)) - exp(-L1 * observe)) / (L1 * enrol)) ^ (-1) P32 <- L2 ^ 2 * (1 - (exp(-L2 * (observe - enrol)) - exp(-L2 * observe)) / (L2 * enrol)) ^ (-1) } if (enrol == 0) { N <- ((ZA * sqrt(P10 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P11/Q1 + P12/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } else if (enrol > 0 && observe > enrol) { N <- ((ZA * sqrt(P30 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P31/Q1 + P32/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } else if (enrol == observe) { # N <- ((ZA * sqrt(P20 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P21/Q1 + P22/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) N <- ((ZA * sqrt(P30 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P31/Q1 + P32/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } N1 <- ceiling(N) N2 <- ceiling(N * ratio) res <- data.frame(c(group1, group2, followup, enrol, observe, alpha, side, power, ratio, " ", gettextRcmdr("Estimated"), N1, N2)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P1", "P2", "(Follow-up duration for P1, P2)", "Enrollment duration", "Total study duration", "Alpha", " ", "Power", "N2/N1", " ", "Required sample size", "N1", "N2")) x <- NULL y <- seq(0.2, 1, 0.05) for (i in 1: length(y)){ ZB <- qnorm(y[i]) if (enrol == 0) { x[i] <- ((ZA * sqrt(P10 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P11/Q1 + P12/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } else if (enrol > 0 && observe > enrol) { x[i] <- ((ZA * sqrt(P30 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P31/Q1 + P32/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } else if (enrol == observe) { # x[i] <- ((ZA * sqrt(P20 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P21/Q1 + P22/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) x[i] <- ((ZA * sqrt(P30 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P31/Q1 + P32/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } } plot(x, y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") abline(h=power, lty=2) return(res) } PowerHazard <- function (enrol, observe, followup, group1, group2, alpha, sample, method, ratio) { #from Jitsuyo SAS Seibutsu Tokei Handbook side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha / method ZA <- qnorm(1-alpha2) L1 <- -log(group1) / followup L2 <- -log(group2) / followup LBER <- (L1 + L2) / 2 Q1 <- 1 / (1 + ratio) Q2 <- ratio / (1 + ratio) P00 <- LBER ^2 P01 <- L1 ^ 2 P02 <- L2 ^ 2 P10 <- LBER ^ 2 / (1 - exp(-LBER * observe)) P11 <- L1 ^ 2 / ( 1 - exp(-L1 * observe)) P12 <- L2 ^ 2 / (1 - exp(-L2 * observe)) P20 <- LBER ^ 3 * followup / (LBER * observe - 1 + exp(-LBER * observe)) P21 <- L1 ^ 3 * followup / (L1 * observe - 1 + exp(-L1 * observe)) P22 <- L2 ^ 3 * followup / (L2 * observe - 1 + exp(-L2 * observe)) if (enrol>0){ P30 <- LBER ^ 2 * (1 - (exp(-LBER * (observe - enrol)) - exp(-LBER * observe)) / (LBER * enrol)) ^ (-1) P31 <- L1 ^ 2 * (1 - (exp(-L1 * (observe - enrol)) - exp(-L1 * observe)) / (L1 * enrol)) ^ (-1) P32 <- L2 ^ 2 * (1 - (exp(-L2 * (observe - enrol)) - exp(-L2 * observe)) / (L2 * enrol)) ^ (-1) } if (enrol == 0) { ZB <- (sqrt(sample * (1 + ratio)) * abs(L1 - L2) - ZA * sqrt(P10 * (1 / Q2 + 1 / Q1))) / sqrt(P11/Q1 + P12/Q2) # N <- ((ZA * sqrt(P10 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P11/Q1 + P12/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } else if (enrol > 0 && observe > enrol) { ZB <- (sqrt(sample * (1 + ratio)) * abs(L1 - L2) - ZA * sqrt(P30 * (1 / Q2 + 1 / Q1))) / sqrt(P31/Q1 + P32/Q2) # N <- ((ZA * sqrt(P30 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P31/Q1 + P32/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } else if (enrol == observe) { # ZB <- (sqrt(sample * (1 + ratio)) * abs(L1 - L2) - ZA * sqrt(P20 * (1 / Q2 + 1 / Q1))) / sqrt(P21/Q1 + P22/Q2) ZB <- (sqrt(sample * (1 + ratio)) * abs(L1 - L2) - ZA * sqrt(P30 * (1 / Q2 + 1 / Q1))) / sqrt(P31/Q1 + P32/Q2) # N <- ((ZA * sqrt(P20 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P21/Q1 + P22/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } N1 <- sample N2 <- round(N1 * ratio, 0) power <- signif(pnorm(ZB), digits=3) res <- data.frame(c(group1, group2, followup, enrol, observe, alpha, side, " ", N1, N2, " ", gettextRcmdr("Estimated"), power)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P1", "P2", "(Follow-up duration for P1, P2)", "Enrollment duration", "Total study duration", "Alpha", " ", "Sample size", "N1", "N2", " ", " ", "Power")) x <- NULL y <- seq(0.2, 1, 0.05) for (i in 1: length(y)){ ZB <- qnorm(y[i]) if (enrol == 0) { x[i] <- ((ZA * sqrt(P10 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P11/Q1 + P12/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } else if (enrol > 0 && observe > enrol) { x[i] <- ((ZA * sqrt(P30 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P31/Q1 + P32/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } else if (enrol == observe) { # x[i] <- ((ZA * sqrt(P20 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P21/Q1 + P22/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) x[i] <- ((ZA * sqrt(P30 * (1 / Q2 + 1 / Q1)) + ZB * sqrt(P31/Q1 + P32/Q2)) / abs(L1 - L2)) ^ 2 / (1 + ratio) } } plot(x, y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") abline(v=sample, lty=2) return(res) } SampleMeanNonInf <- function (difference, delta, sd, alpha, power, method) { #method = 2 for two sided, 1 for one sided, r for group2/group1 ratio #from Jitsuyo SAS Seibutsu Tokei Handbook side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha / method ZA <- qnorm(1-alpha2) # alpha <- alpha / method # ZA <- qnorm(1-alpha) ZB <- qnorm(power) N1 <- ceiling(2*(((ZA+ZB)/((difference+delta)/sd))^2)) N2 <- N1 res <- data.frame(c(difference, delta, sd, alpha, side, power, " ", gettextRcmdr("Estimated"), N1, N2)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("Difference in means", "Delta", "Standard deviation", "Alpha", " ", "Power", " ", "Required sample size", "N1", "N2")) y <- seq(0.2, 1, 0.05) plot(2*(((ZA+qnorm(y))/((difference+delta)/sd))^2), y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") abline(h=power, lty=2) return(res) } SampleHazardNonInf <- function (enrol, observe, followup, group1, group2, lowerlimit, alpha, power, method, ratio) { #From SWOG https://stattools.crab.org/ side <- ifelse(method == 1, "one-sided", "two-sided") side <- gettextRcmdr(side) alpha2 <- alpha / method ZA <- qnorm(1-alpha2) # alpha <- alpha / method # ZA <- qnorm(1-alpha) ZB <- qnorm(power) L1 <- -log(group1) / followup #L1 hazard rate 1 (control) L2 <- -log(group2) / followup #L2 hazard rate 2 (experimental), thus L2/L1 is the hazard ratio L3 <- -log(lowerlimit) / followup #L3 hazard of lower limit Q1 <- 1 / (1 + ratio) Q2 <- ratio / (1 + ratio) E11 <- 1 - exp(-L1 * observe) #Event rate in 1 if (enrol == 0) E12 <- 1 - exp(-L2 * observe) #Event rate in 1 if (enrol == 0) E21 <- (L1 * observe - 1 + exp(-L1 * observe)) / (L1*followup) #Event rate in 1 if (enrol == observe) E22 <- (L2 * observe - 1 + exp(-L2 * observe)) / (L2*followup) #Event rate in 1 if (enrol == observe) E31 <- 1 - (exp(-L1 * (observe - enrol)) - exp(-L1 * observe)) / (L1 * enrol) #Event rate in 1 if (enrol > 0 && observe > enrol) E32 <- 1 - (exp(-L2 * (observe - enrol)) - exp(-L2 * observe)) / (L2 * enrol) #Event rate in 2 if (enrol > 0 && observe > enrol) Delta <- log((L2/L1) / (L3/L1)) if (enrol == 0) { E1 <- E11; E2 <- E12 } else if (enrol > 0 && observe > enrol) { E1 <- E31; E2 <- E32 } else if (enrol == observe) { # E1 <- E21; E2 <- E22 E1 <- E31; E2 <- E32 } N <- (ZA + ZB)^2 * ((1/(Q1*E1)) + (1/(Q2*E2))) / (Delta^2) N1 <- ceiling(N * Q1) N2 <- ceiling(N * Q2) res <- data.frame(c(group1, group2, lowerlimit, followup, enrol, observe, alpha, side, power, ratio, " ", gettextRcmdr("Estimated"), N1, N2)) colnames(res) <- gettextRcmdr("Assumptions") rownames(res) <- gettextRcmdr(c("P1", "P2", "Non-inferiority lower limit", "(Follow-up duration for P1, P2)", "Enrollment duration", "Total study duration", "Alpha", " ", "Power", "N2/N1", " ", "Required sample size", "N1", "N2")) x <- NULL y <- seq(0.2, 1, 0.05) for (i in 1: length(y)){ ZB <- qnorm(y[i]) x[i] <- ((ZA + ZB)^2 * ((1/(Q1*E1)) + (1/(Q2*E2))) / (Delta^2)) * Q1 } plot(x, y, ylim=c(0,1), type="l", ylab="Power", xlab="N1") abline(h=power, lty=2) return(res) } StatMedGroupsBox <- defmacro(recall=NULL, label=gettextRcmdr("Plot by:"), initialLabel=gettextRcmdr("Plot by groups"), plotLinesByGroup=FALSE, positionLegend=FALSE, plotLinesByGroupsText=gettextRcmdr("Plot lines by group"), expr={ env <- environment() .groups <- FALSE .linesByGroup <- FALSE .groupsLabel <- tclVar(paste(initialLabel, "...", sep="")) .factors <- Variables() onGroups <- function(){ if (length(.factors) == 0){ errorCondition(recall=recall, message=gettextRcmdr("There are no factors in the active data set.")) return() } initializeDialog(subdialog, title=gettextRcmdr("Groups")) groupsBox <- variableListBox(subdialog, .factors, title=gettextRcmdr("Groups variable (pick one)")) if (plotLinesByGroup){ linesByGroupFrame <- tkframe(subdialog) linesByGroup <- tclVar("1") linesCheckBox <- tkcheckbutton(linesByGroupFrame, variable=linesByGroup) tkgrid(labelRcmdr(linesByGroupFrame, text=plotLinesByGroupsText), linesCheckBox, sticky="w") } onOKsub <- function() { groups <- getSelection(groupsBox) if (length(groups) == 0){ assign(".groups", FALSE, envir=env) tclvalue(.groupsLabel) <- paste(initialLabel, "...", sep="") tkconfigure(groupsButton, foreground="black") if (GrabFocus()) tkgrab.release(subdialog) tkdestroy(subdialog) tkwm.deiconify(top) if (GrabFocus()) tkgrab.set(top) tkfocus(top) tkwait.window(top) return() } assign(".groups", groups, envir=env) tclvalue(.groupsLabel) <- paste(label, groups) tkconfigure(groupsButton, foreground="blue") if (plotLinesByGroup) { lines <- as.character("1" == tclvalue(linesByGroup)) assign(".linesByGroup", lines, envir=env) } if (GrabFocus()) tkgrab.release(subdialog) tkdestroy(subdialog) tkwm.deiconify(top) if (GrabFocus()) tkgrab.set(top) tkfocus(top) tkwait.window(top) } subOKCancelHelp() tkgrid(getFrame(groupsBox), sticky="nw") if (plotLinesByGroup) tkgrid(linesByGroupFrame, sticky="w") tkgrid(subButtonsFrame, sticky="w") if (positionLegend) tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Position legend with mouse click"), fg="blue")) dialogSuffix(subdialog, onOK=onOKsub, rows=3+plotLinesByGroup+positionLegend, columns=2, focus=subdialog, force.wait=TRUE) } groupsFrame <- tkframe(top) groupsButton <- tkbutton(groupsFrame, textvariable=.groupsLabel, command=onGroups, borderwidth=3) tkgrid(labelRcmdr(groupsFrame, text=" "), groupsButton, sticky="w") }) StatMedSubsetBox <- defmacro(window=top, model=FALSE, expr={ subsetVariable <- if (model){ if (currentModel && currentFields$subset != "") tclVar(currentFields$subset) else tclVar(gettextRcmdr("<all valid cases>")) } else tclVar(gettextRcmdr("<all valid cases>")) # subsetVariable <- ifelse (!is.null(currentFields$subset) & currentFields$subset != "", # tclVar(currentFields$subset), # tclVar(gettextRcmdr("<all valid cases>"))) subsetFrame <- tkframe(window) subsetEntry <- ttkentry(subsetFrame, width="60", textvariable=subsetVariable) subsetScroll <- ttkscrollbar(subsetFrame, orient="horizontal", command=function(...) tkxview(subsetEntry, ...)) tkconfigure(subsetEntry, xscrollcommand=function(...) tkset(subsetScroll, ...)) tkgrid(labelRcmdr(subsetFrame, text=gettextRcmdr("Condition to limit samples for analysis. Ex1. age>50 & Sex==0 Ex2. age<50 | Sex==1"), foreground="blue"), sticky="w") tkgrid(subsetEntry, sticky="w") tkgrid(subsetScroll, sticky="ew") }) StatMedModelFormula <- defmacro(frame=top, hasLhs=TRUE, expr={ checkAddOperator <- function(rhs){ rhs.chars <- rev(strsplit(rhs, "")[[1]]) if (length(rhs.chars) < 1) return(FALSE) check.char <- if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1)) rhs.chars[1] else rhs.chars[2] !is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%")) } .variables <- Variables() word <- paste("\\[", gettextRcmdr("factor"), "\\]", sep="") variables <- paste(.variables, ifelse(is.element(.variables, Factors()), paste("[", gettextRcmdr("factor"), "]", sep=""), "")) xBox <- variableListBox(frame, variables, selectmode="multiple", title=gettextRcmdr("Variables (double-click to formula)"), listHeight=10) onDoubleClick <- if (!hasLhs){ function(){ var <- getSelection(xBox) tkselection.clear(xBox$listbox, "0", "end") if (length(grep(word, var)) == 1) var <- sub(word, "", var) tkfocus(rhsEntry) rhs <- tclvalue(rhsVariable) rhs.chars <- rev(strsplit(rhs, "")[[1]]) check.char <- if (length(rhs.chars) > 0){ if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1)) rhs.chars[1] else rhs.chars[2] } else "" tclvalue(rhsVariable) <- if (rhs == "" || is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%"))) paste(rhs, var, sep="") else paste(rhs, "+", var) tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } } else{ function(){ var <- getSelection(xBox) which <- tkcurselection(xBox$listbox) tkselection.clear(xBox$listbox, "0", "end") if (length(grep(word, var)) == 1) var <- sub(word, "", var) lhs <- tclvalue(lhsVariable) if (lhs == "" || tclvalue(tkselection.present(lhsEntry)) == "1"){ tclvalue(lhsVariable) <- var tkselection.clear(lhsEntry) tkfocus(rhsEntry) } else { tkfocus(rhsEntry) rhs <- tclvalue(rhsVariable) rhs.chars <- rev(strsplit(rhs, "")[[1]]) check.char <- if (length(rhs.chars) > 0){ if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1)) rhs.chars[1] else rhs.chars[2] } else "" tclvalue(rhsVariable) <- if (rhs == "" || is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%"))) paste(rhs, var, sep="") else paste(rhs, "+", var) } tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } } tkbind(xBox$listbox, "<Double-ButtonPress-1>", onDoubleClick) onPlus <- function(){ rhs <- tclvalue(rhsVariable) var <- getSelection(xBox) tkselection.clear(xBox$listbox, "0", "end") if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return() if (length(var) > 1){ if (length(grep(word, var)) > 0) var <- sub(word, "", var) if (length(var) > 1) var <- paste(var, collapse=" + ") } tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onTimes <- function(){ rhs <- tclvalue(rhsVariable) var <- getSelection(xBox) tkselection.clear(xBox$listbox, "0", "end") if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return() if (length(var) > 1){ if (length(grep(word, var)) > 0) var <- sub(word, "", var) var <- trim.blanks(var) if (length(var) > 1) var <- paste(var, collapse="*") tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="") } else tclvalue(rhsVariable) <- paste(rhs, if (!check) "*", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onColon <- function(){ rhs <- tclvalue(rhsVariable) var <- getSelection(xBox) tkselection.clear(xBox$listbox, "0", "end") if ((check <- !checkAddOperator(rhs)) && length(var) == 0) return() if (length(var) > 1){ if (length(grep(word, var)) > 0) var <- sub(word, "", var) var <- trim.blanks(var) if (length(var) > 1) var <- paste(var, collapse=":") tclvalue(rhsVariable) <- paste(rhs, if (!check) " + ", var, sep="") } else tclvalue(rhsVariable) <- paste(rhs, if (!check) ":", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onSlash <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "/", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onIn <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "%in% ") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onMinus <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "- ") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onPower <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "^", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onLeftParen <- function(){ tkfocus(rhsEntry) rhs <- tclvalue(rhsVariable) tclvalue(rhsVariable) <- paste(rhs, "(", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onRightParen <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, ")", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } outerOperatorsFrame <- tkframe(frame) operatorsFrame <- tkframe(outerOperatorsFrame) plusButton <- buttonRcmdr(operatorsFrame, text="+", width="3", command=onPlus) timesButton <- buttonRcmdr(operatorsFrame, text="*", width="3", command=onTimes) colonButton <- buttonRcmdr(operatorsFrame, text=":", width="3", command=onColon) slashButton <- buttonRcmdr(operatorsFrame, text="/", width="3", command=onSlash) inButton <- buttonRcmdr(operatorsFrame, text="%in%", width="5", command=onIn) minusButton <- buttonRcmdr(operatorsFrame, text="-", width="3", command=onMinus) powerButton <- buttonRcmdr(operatorsFrame, text="^", width="3", command=onPower) leftParenButton <- buttonRcmdr(operatorsFrame, text="(", width="3", command=onLeftParen) rightParenButton <- buttonRcmdr(operatorsFrame, text=")", width="3", command=onRightParen) tkgrid(plusButton, timesButton, colonButton, slashButton, inButton, minusButton, powerButton, leftParenButton, rightParenButton, sticky="w") formulaFrame <- tkframe(frame) if (hasLhs){ tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Model Formula: "), fg="blue"), operatorsFrame) lhsVariable <- if (currentModel) tclVar(currentFields$lhs) else tclVar("") rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("") rhsEntry <- ttkentry(formulaFrame, width="50", textvariable=rhsVariable) rhsXscroll <- ttkscrollbar(formulaFrame, orient="horizontal", command=function(...) tkxview(rhsEntry, ...)) tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...)) lhsEntry <- ttkentry(formulaFrame, width="10", textvariable=lhsVariable) lhsScroll <- ttkscrollbar(formulaFrame, orient="horizontal", command=function(...) tkxview(lhsEntry, ...)) tkconfigure(lhsEntry, xscrollcommand=function(...) tkset(lhsScroll, ...)) tkgrid(labelRcmdr(formulaFrame, text=gettextRcmdr("Objective variable")), lhsEntry, labelRcmdr(formulaFrame, text=gettextRcmdr("~ Explanatory variables")), rhsEntry, sticky="w") tkgrid(lhsScroll, labelRcmdr(formulaFrame, text=""), rhsXscroll, sticky="w") tkgrid.configure(lhsScroll, sticky="ew") } else{ rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("") rhsEntry <- ttkentry(formulaFrame, width="50", textvariable=rhsVariable) rhsXscroll <- ttkscrollbar(formulaFrame, orient="horizontal", command=function(...) tkxview(rhs, ...)) tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...)) tkgrid(labelRcmdr(formulaFrame, text=" ~ "), rhsEntry, sticky="w") tkgrid(labelRcmdr(formulaFrame, text=""), rhsXscroll, sticky="w") } tkgrid.configure(rhsXscroll, sticky="ew") }) modelFormulaCox <- defmacro(frame=top, hasLhs=TRUE, expr={ # from RcmdrPlugin.SurvivalT checkAddOperator <- function(rhs){ rhs.chars <- rev(strsplit(rhs, "")[[1]]) if (length(rhs.chars) < 1) return(FALSE) check.char <- if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1)) rhs.chars[1] else rhs.chars[2] !is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%")) } .variables <- Variables() word <- paste("\\[", gettextRcmdr("factor"), "\\]", sep="") variables <- paste(.variables, ifelse(is.element(.variables, Factors()), paste("[", gettextRcmdr("factor"), "]", sep=""), "")) xBox <- variableListBox(frame, variables, title=gettextRcmdr("Variables (double-click to formula)"), listHeight=8) onDoubleClick <- if (!hasLhs){ function(){ var <- getSelection(xBox) if (length(grep(word, var)) == 1) var <- sub(word, "", var) tkfocus(rhsEntry) rhs <- tclvalue(rhsVariable) rhs.chars <- rev(strsplit(rhs, "")[[1]]) check.char <- if (length(rhs.chars) > 0){ if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1)) rhs.chars[1] else rhs.chars[2] } else "" tclvalue(rhsVariable) <- if (rhs == "" || is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%"))) paste(rhs, var, sep="") else paste(rhs, "+", var) tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } } else{ function(){ var <- getSelection(xBox) if (length(grep(word, var)) == 1) var <- sub(word, "", var) lhs <- tclvalue(SurvivalTimeVariable) lhs2 <- tclvalue(StatusVariable) if (lhs == "") tclvalue(SurvivalTimeVariable) <- var else { if (lhs2 == "") tclvalue(StatusVariable) <- var else { tkfocus(rhsEntry) rhs <- tclvalue(rhsVariable) rhs.chars <- rev(strsplit(rhs, "")[[1]]) check.char <- if (length(rhs.chars) > 0){ if ((rhs.chars[1] != " ") || (length(rhs.chars) == 1)) rhs.chars[1] else rhs.chars[2] } else "" tclvalue(rhsVariable) <- if (rhs == "" || is.element(check.char, c("+", "*", ":", "/", "-", "^", "(", "%"))) paste(rhs, var, sep="") else paste(rhs, "+", var) } } tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } } tkbind(xBox$listbox, "<Double-ButtonPress-1>", onDoubleClick) onPlus <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "+ ") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onTimes <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "*", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onColon <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, ":", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onSlash <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "/", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onIn <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "%in% ") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onMinus <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "- ") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onPower <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, "^", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onLeftParen <- function(){ tkfocus(rhsEntry) rhs <- tclvalue(rhsVariable) tclvalue(rhsVariable) <- paste(rhs, "(", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } onRightParen <- function(){ rhs <- tclvalue(rhsVariable) if (!checkAddOperator(rhs)) return() tclvalue(rhsVariable) <- paste(rhs, ")", sep="") tkicursor(rhsEntry, "end") tkxview.moveto(rhsEntry, "1") } outerOperatorsFrame <- tkframe(frame) operatorsFrame <- tkframe(outerOperatorsFrame) plusButton <- buttonRcmdr(operatorsFrame, text="+", width="3", command=onPlus) timesButton <- buttonRcmdr(operatorsFrame, text="*", width="3", command=onTimes) colonButton <- buttonRcmdr(operatorsFrame, text=":", width="3", command=onColon) slashButton <- buttonRcmdr(operatorsFrame, text="/", width="3", command=onSlash) inButton <- buttonRcmdr(operatorsFrame, text="%in%", width="5", command=onIn) minusButton <- buttonRcmdr(operatorsFrame, text="-", width="3", command=onMinus) powerButton <- buttonRcmdr(operatorsFrame, text="^", width="3", command=onPower) leftParenButton <- buttonRcmdr(operatorsFrame, text="(", width="3", command=onLeftParen) rightParenButton <- buttonRcmdr(operatorsFrame, text=")", width="3", command=onRightParen) tkgrid(plusButton, timesButton, colonButton, slashButton, inButton, minusButton, powerButton, leftParenButton, rightParenButton, sticky="w") formulaFrame <- tkframe(frame) if (hasLhs){ tkgrid(labelRcmdr(outerOperatorsFrame, text=gettextRcmdr("Model Formula: "), fg="blue"), operatorsFrame) SurvivalTimeVariable <- if (currentModel) tclVar(currentFields$SurvivalTimeVariable) else tclVar("") StatusVariable <- if (currentModel) tclVar(currentFields$StatusVariable) else tclVar("") rhsVariable <- if (currentModel) tclVar(currentFields$rhs) else tclVar("") rhsEntry <- ttkentry(formulaFrame, width="50", textvariable=rhsVariable) rhsXscroll <- ttkscrollbar(formulaFrame, orient="horizontal", command=function(...) tkxview(rhs, ...)) tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...)) lhsEntry <- ttkentry(formulaFrame, width="10", textvariable=SurvivalTimeVariable) lhsScroll <- ttkscrollbar(formulaFrame, orient="horizontal", command=function(...) tkxview(lhsEntry, ...)) tkconfigure(lhsEntry, xscrollcommand=function(...) tkset(lhsScroll, ...)) lhsEntry2 <- ttkentry(formulaFrame, width="10", textvariable=StatusVariable) lhsScroll2 <- ttkscrollbar(formulaFrame, orient="horizontal", command=function(...) tkxview(lhsEntry2, ...)) tkconfigure(lhsEntry2, xscrollcommand=function(...) tkset(lhsScroll2, ...)) tkgrid(labelRcmdr(formulaFrame, text=gettextRcmdr("Time")), lhsEntry, labelRcmdr(formulaFrame, text=gettextRcmdr(", Event")), lhsEntry2, labelRcmdr(formulaFrame, text=gettextRcmdr("~ Explanatory variables")), rhsEntry, sticky="w") tkgrid(labelRcmdr(formulaFrame, text=""), lhsScroll, labelRcmdr(formulaFrame, text=""), lhsScroll2, labelRcmdr(formulaFrame, text=""), rhsXscroll, sticky="w") tkgrid.configure(lhsScroll, sticky="ew") } else{ rhsVariable <- tclVar("") rhsEntry <- ttkentry(formulaFrame, width="50", textvariable=rhsVariable) rhsXscroll <- ttkscrollbar(formulaFrame, orient="horizontal", command=function(...) tkxview(rhs, ...)) tkconfigure(rhsEntry, xscrollcommand=function(...) tkset(rhsXscroll, ...)) tkgrid(labelRcmdr(formulaFrame, text=" ~ "), rhsEntry, sticky="w") tkgrid(labelRcmdr(formulaFrame, text=""), rhsXscroll, sticky="w") } tkgrid.configure(rhsXscroll, sticky="ew") }) listCoxModels <- function(envir=.GlobalEnv, ...) { # from RcmdrPlugin.SurvivalT objects <- ls(envir=envir, ...) if (length(objects) == 0) NULL else objects[sapply(objects, # function(.x) "coxph" == (class(eval(parse(text=.x), envir=envir))[1]))] function(.x) "coxph" == (class(get(.x, envir=envir))[1]))] } listLMModels <- function(envir=.GlobalEnv, ...) { objects <- ls(envir=envir, ...) if (length(objects) == 0) NULL else objects[sapply(objects, function(.x) "lm" == (class(get(.x, envir=envir))[1]))] } StatMedLoadDataSet <- function() { logger(paste("#####", gettextRcmdr("Load data set"), "#####", sep="")) file <- tclvalue(tkgetOpenFile(filetypes= gettextRcmdr('{"R Data Files" {".RData" ".rda" ".Rda" ".RDA"}} {"All Files" {"*"}}'))) # file <- tclvalue(tkgetOpenFile(filetypes= # gettextRcmdr('{"All Files" {"*"}} {"R Data Files" {".RData" ".rda" ".Rda" ".RDA"}}'))) if (file == "") return() setBusyCursor() on.exit(setIdleCursor()) command <- paste('load("', file,'")', sep="") dsname <- justDoIt(command) logger(command) if (class(dsname)[1] != "try-error") { if (length(dsname) > 1) { Message(message=paste(gettextRcmdr("There is more than one object in the file, with the following names:\n"), paste(dsname, collapse=", ")), type="error") return() } activeDataSet(dsname) } tkfocus(CommanderWindow()) } StatMedReadDataSet <- function() { initializeDialog(title=gettextRcmdr("Read Text Data From File, Clipboard, or URL")) optionsFrame <- tkframe(top) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- ttkentry(optionsFrame, width="20", textvariable=dsname) radioButtons(optionsFrame, "location", buttons=c("local", "clipboard", "url"), labels=gettextRcmdr(c("Local file system", "Clipboard", "Internet URL")), title=gettextRcmdr("Location of Data File")) headerVariable <- tclVar("1") headerCheckBox <- tkcheckbutton(optionsFrame, variable=headerVariable) fillVariable <- tclVar("1") fillCheckBox <- tkcheckbutton(optionsFrame, variable=fillVariable) blankVariable <- tclVar("1") blankCheckBox <- tkcheckbutton(optionsFrame, variable=blankVariable) ## clipboardVariable <- tclVar("0") ## clipboardCheckBox <- tkcheckbutton(optionsFrame, variable=clipboardVariable) radioButtons(optionsFrame, "delimiter", buttons=c("whitespace", "commas", "tabs"), initialValue="commas", labels=gettextRcmdr(c("White space", "Commas", "Tabs")), title=gettextRcmdr("Field Separator")) otherButton <- ttkradiobutton(delimiterFrame, variable=delimiterVariable, value="other") otherVariable <- tclVar("") otherEntry <- ttkentry(delimiterFrame, width="4", textvariable=otherVariable) radioButtons(optionsFrame, "decimal", buttons=c("period", "comma"), labels=gettextRcmdr(c("Period [.]", "Comma [,]")), title=gettextRcmdr("Decimal-Point Character")) missingVariable <- tclVar("NA") missingEntry <- ttkentry(optionsFrame, width="8", textvariable=missingVariable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Read Data From Text File"), "#####", sep="")) closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == ""){ errorCondition(recall=StatMedReadDataSet, message=gettextRcmdr("You must enter a name for the data set.")) return() } if (!is.valid.name(dsnameValue)){ errorCondition(recall=StatMedReadDataSet, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ StatMedReadDataSet() return() } } ## clip <- tclvalue(clipboardVariable) == "1" location <- tclvalue(locationVariable) file <- if (location == "clipboard") "clipboard" else if (location == "local") tclvalue(tkgetOpenFile(filetypes= # gettextRcmdr('{"All Files" {"*"}} {"Text Files" {".txt" ".TXT" ".dat" ".DAT" ".csv" ".CSV"}}'))) gettextRcmdr('{"Text Files" {".txt" ".TXT" ".dat" ".DAT" ".csv" ".CSV"}} {"All Files" {"*"}}'))) else { initializeDialog(subdialog, title=gettextRcmdr("Internet URL")) onOKsub <- function(){ closeDialog(subdialog) } urlFrame <- tkframe(subdialog) urlVar <- tclVar("") url <- ttkentry(urlFrame, font=getRcmdr("logFont"), width="30", textvariable=urlVar) urlXscroll <- ttkscrollbar(urlFrame, orient="horizontal", command=function(...) tkxview(url, ...)) tkconfigure(url, xscrollcommand=function(...) tkset(urlXscroll, ...)) subOKCancelHelp() tkgrid(url, sticky="w") tkgrid(urlXscroll, sticky="ew") tkgrid(urlFrame, sticky="nw") tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subdialog, rows=2, columns=1, focus=url, onOK=onOKsub, force.wait=TRUE) tclvalue(urlVar) } if (file == "") { if (getRcmdr("grab.focus")) tkgrab.release(top) tkdestroy(top) return() } head <- tclvalue(headerVariable) == "1" fill <- tclvalue(fillVariable) if (fill == 0){ fill <- "" }else{ fill <- ", fill=TRUE" } delimiter <- tclvalue(delimiterVariable) del <- if (delimiter == "whitespace") "" else if (delimiter == "commas") "," else if (delimiter == "tabs") "\\t" else tclvalue(otherVariable) blank <- tclvalue(blankVariable) miss <- tclvalue(missingVariable) if (blank == 1) { miss <- paste('c("", "', miss, '")', sep="") } else { miss <- paste('"', miss, '"', sep="") } dec <- if (tclvalue(decimalVariable) == "period") "." else "," if (file == "clipboard" & MacOSXP()==TRUE) { command <- paste('read.table(pipe("pbpaste"), header=', head, ', sep="', del, '", na.strings=', miss, ', dec="', dec, '"', fill, ', quote="\\"", comment.char="", strip.white=TRUE)', sep="") } else{ command <- paste('read.table("', file,'", header=', head, ', sep="', del, '", na.strings=', miss, ', dec="', dec, '"', fill, ', quote="\\"", comment.char="", strip.white=TRUE)', sep="") } logger(paste(dsnameValue, " <- ", command, sep="")) result <- justDoIt(command) if (class(result)[1] != "try-error"){ # assign(dsnameValue, result, envir=.GlobalEnv) # logger(paste(dsnameValue, "<-", command)) doItAndPrint(paste(dsnameValue, "<-", command)) activeDataSet(dsnameValue) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="read.table") tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="w") tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Variable names in file:")), headerCheckBox, sticky="w") tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Adjust for different column numbers:")), fillCheckBox, sticky="w") ## tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Read data from clipboard:")), clipboardCheckBox, sticky="w") tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Apply NA for blank cells in character variables:")), blankCheckBox, sticky="w") tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Characters indicating NA cells:")), missingEntry, sticky="w") tkgrid(locationFrame, sticky="w") tkgrid(labelRcmdr(delimiterFrame, text=gettextRcmdr("Other")), otherButton, labelRcmdr(delimiterFrame, text=gettextRcmdr(" Specify:")), otherEntry, sticky="w") tkgrid(delimiterFrame, sticky="w", columnspan=2) tkgrid(decimalFrame, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1) } StatMedImportSPSS <- function() { initializeDialog(title=gettextRcmdr("Import SPSS Data Set")) dsnameFrame <- tkframe(top) dsname <- tclVar("Dataset") entryDsname <- ttkentry(dsnameFrame, width="20", textvariable=dsname) asFactorFrame <- tkframe(top) asFactor <- tclVar("1") asFactorCheckBox <- ttkcheckbutton(asFactorFrame, variable=asFactor) toLowerFrame <- tkframe(top) toLower <- tclVar("0") toLowerCheckBox <- ttkcheckbutton(toLowerFrame, variable=toLower) rowNamesFrame <- tkframe(top) rownames <- tclVar("0") rownamesCheckBox <- ttkcheckbutton(rowNamesFrame, variable=rownames) onOK <- function(){ logger(paste("#####", gettextRcmdr("Import SPSS Data Set"), "#####", sep="")) closeDialog() setBusyCursor() on.exit(setIdleCursor()) dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == ""){ errorCondition(recall=importSPSS, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)){ errorCondition(recall=importSPSS, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ importSPSS() return() } } file <- tclvalue(tkgetOpenFile( # filetypes=gettextRcmdr('{"All Files" {"*"}} {"SPSS portable files" {".por" ".POR"}} {"SPSS save files" {".sav" ".SAV"}}'))) filetypes=gettextRcmdr('{"SPSS save files" {".sav" ".SAV"}} {"SPSS portable files" {".por" ".POR"}} {"All Files" {"*"}}'))) if (file == "") { tkfocus(CommanderWindow()) return() } factor <- tclvalue(asFactor) == "1" lower <- tclvalue(toLower) == "1" rows <- tclvalue(rownames) == "1" command <- paste('readSPSS("', file,'", rownames=', rows, ", stringsAsFactors=", factor, ", tolower=", lower, ")", sep="") logger(paste(dsnameValue, " <- ", command, sep="")) result <- justDoIt(command) if (class(result)[1] != "try-error"){ gassign(dsnameValue, result) activeDataSet(dsnameValue) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="readSPSS") tkgrid(labelRcmdr(dsnameFrame, text=gettextRcmdr("Enter name for data set: ")), entryDsname, sticky="w") tkgrid(dsnameFrame, sticky="w") tkgrid(asFactorCheckBox, labelRcmdr(asFactorFrame, text=gettextRcmdr("Convert character variables to factors"), justify="left"), sticky="nw") tkgrid(asFactorFrame, sticky="w") tkgrid(rownamesCheckBox, labelRcmdr(rowNamesFrame, text=gettextRcmdr("First column contains row names"), justify="left"), sticky="w") tkgrid(rowNamesFrame, sticky="w") tkgrid(toLowerCheckBox, labelRcmdr(toLowerFrame, text=gettextRcmdr("Convert variable names to lower case"), justify="left"), sticky="nw") tkgrid(toLowerFrame, sticky="w") tkgrid(buttonsFrame, sticky="ew") dialogSuffix(focus=entryDsname) } StatMedImportMinitab <- function() { Library("foreign") initializeDialog(title=gettextRcmdr("Import Minitab Data Set")) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- ttkentry(top, width="20", textvariable=dsname) onOK <- function(){ logger(paste("#####", gettextRcmdr("Import Minitab Data Set"), "#####", sep="")) closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == ""){ errorCondition(recall=StatMedImportMinitab, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)){ errorCondition(recall=StatMedImportMinitab, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ importMinitab() return() } } file <- tclvalue(tkgetOpenFile( # filetypes=gettextRcmdr('{"All Files" {"*"}} {"Minitab portable files" {".mtp" ".MTP"}}'))) filetypes=gettextRcmdr('{"Minitab portable files" {".mtp" ".MTP"}} {"All Files" {"*"}}'))) if (file == "") { tkfocus(CommanderWindow()) return() } command <- paste('read.mtp("', file,'")', sep="") datalist <- justDoIt(command) lengths <- sapply(datalist, length) datalist <- datalist[lengths != 0] lengths <- lengths[lengths != 0] if (!all(lengths == length(datalist[[1]]))){ Message(message= paste(gettextRcmdr("Minitab data set contains elements of unequal length.\nData set cannot be converted.")), type="error") tkdestroy(top) tkfocus(CommanderWindow()) return() } # assign(dsnameValue, as.data.frame(datalist), envir=.GlobalEnv) # logger(paste(dsnameValue, " <- as.data.frame(", command, ")", sep="")) doItAndPrint(paste(dsnameValue, " <- as.data.frame(", command, ")", sep="")) activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="read.mtp") tkgrid(labelRcmdr(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e") tkgrid(buttonsFrame, columnspan="2", sticky="w") tkgrid.configure(entryDsname, sticky="w") dialogSuffix(rows=2, columns=2, focus=entryDsname) } readStataEZR <- function(file, rownames=FALSE, stringsAsFactors=FALSE, convert.factors=TRUE, convert.dates=TRUE, convert.underscore=TRUE, ...){ Data <- readstata13::read.dta13(file, convert.factors=stringsAsFactors, convert.dates=convert.dates, convert.underscore=convert.underscore, ...) ###Just added convert.underscore = FALSE as option for EZR ###default.stringsAsFactors() was deprecated from R 4.0.0 and changed to FALSE from EZR ver 1.50 if (rownames){ check <- length(unique(col1 <- Data[[1]])) == nrow(Data) if (!check) warning ("row names are not unique, ignored") else { rownames(Data) <- col1 Data[[1]] <- NULL } } if (stringsAsFactors){ char.cols <- sapply(Data, class) == "character" if (any(char.cols)){ for (col in names(Data)[char.cols]){ fac <- Data[, col] fac[fac == ""] <- NA Data[, col] <- as.factor(fac) } } } Data } StatMedImportSTATA <- function() { initializeDialog(title=gettextRcmdr("Import STATA Data Set")) dsname <- tclVar("Dataset") dsnameFrame <- tkframe(top) entryDsname <- ttkentry(dsnameFrame, width="20", textvariable=dsname) optionsFrame <- tkframe(top) asFactor <- tclVar("1") asFactorCheckBox <- ttkcheckbutton(optionsFrame, variable=asFactor) convertFactor <- tclVar("1") convertFactorCheckBox <- ttkcheckbutton(optionsFrame, variable=convertFactor) asDate <- tclVar("1") asDateCheckBox <- ttkcheckbutton(optionsFrame, variable=asDate) convertunderscore <- tclVar("1") convertunderscoreCheckBox <- ttkcheckbutton(optionsFrame, variable=convertunderscore) rownames <- tclVar("0") rownamesCheckBox <- ttkcheckbutton(optionsFrame, variable=rownames) onOK <- function(){ logger(paste("#####", gettextRcmdr("Import Stata Data Set"), "#####", sep="")) closeDialog() setBusyCursor() on.exit(setIdleCursor()) dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == ""){ errorCondition(recall=importSTATA, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)){ errorCondition(recall=importSTATA, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ StatMedImportSTATA() return() } } file <- tclvalue(tkgetOpenFile( # filetypes=gettextRcmdr('{"All Files" {"*"}} {"STATA datasets" {".dta" ".DTA"}}'))) filetypes=gettextRcmdr('{"STATA datasets" {".dta" ".DTA"}} {"All Files" {"*"}}'))) if (file == "") { tkfocus(CommanderWindow()) return() } convert.date <- tclvalue(asDate) == "1" convert.underscore <- tclvalue(convertunderscore) == "1" factor <- tclvalue(asFactor) == "1" convertfactor <- tclvalue(convertFactor) == "1" has.rownames <- tclvalue(rownames) == "1" command <- paste('readStataEZR("', file,'", convert.dates=', convert.date, ", convert.factors=", convertfactor, ", nonint.factors=", convertfactor, ", stringsAsFactors=", factor, ", rownames=", has.rownames, ", convert.underscore=", convert.underscore, ")", sep="") logger(paste(dsnameValue, " <- ", command, sep="")) result <- justDoIt(command) if (class(result)[1] != "try-error"){ gassign(dsnameValue, result) activeDataSet(dsnameValue) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="readStata") tkgrid(labelRcmdr(dsnameFrame, text=gettextRcmdr("Enter name for data set: ")), entryDsname, sticky="w") tkgrid(dsnameFrame, columnspan=2, sticky="w") tkgrid(asFactorCheckBox, labelRcmdr(optionsFrame, text=gettextRcmdr("Convert character variables to factors"), justify="left"), sticky="nw") tkgrid(convertFactorCheckBox, labelRcmdr(optionsFrame, text=gettextRcmdr("Use value labels to create factors"), justify="left"), sticky="nw") tkgrid(asDateCheckBox, labelRcmdr(optionsFrame, text=gettextRcmdr("Convert dates to R format"), justify="left"), sticky="w") tkgrid(convertunderscoreCheckBox, labelRcmdr(optionsFrame, text=gettextRcmdr("Convert underscore to period"), justify="left"), sticky="w") tkgrid(rownamesCheckBox, labelRcmdr(optionsFrame, text=gettextRcmdr("First column contains row names"), justify="left"), sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, columnspan="2", sticky="ew") dialogSuffix(focus=entryDsname) } StatMedLoadWorkspace <- function() { logger(paste("#####", gettextRcmdr("Load work space file"), "#####", sep="")) file <- tclvalue(tkgetOpenFile(filetypes= gettextRcmdr('{"R Data Files" {".RData"}} {"All Files" {"*"}}'))) if (file == "") return() command <- paste('load("', file,'")', sep="") dsname <- justDoIt(command) logger(command) tkfocus(CommanderWindow()) } trim.col.na <- function(dat){ # Remove variables with only missing values (occurs sometimes with modified Excel file) colsup <- NULL for (i in 1:ncol(dat)) { if (length(dat[is.na(dat[,i])==T,i]) ==length(dat[,i])) colsup <- c(colsup,i) } if (length(colsup) > 0) dat <- dat[,-colsup] dat } if(.Platform$OS.type == 'windows') StatMedImportRODBCtable <- function(){ # load the RODBC package and stops the program if not available Library("RODBC") #if(!require(RODBC)) # stop("This function requires the RODBC package.") # close all databases in case of error on.exit(odbcCloseAll()) # Enter the name of data set, by default : Dataset initializeDialog(title = gettextRcmdr("Import from Excel, Access or dBase data set")) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- ttkentry(top, width = "35", textvariable = dsname) onOK <- function(){ logger(paste("#####", gettextRcmdr("Import from Excel, Access or dBase data set"), "#####", sep="")) closeDialog() dsnameValue <- trim.blanks(tclvalue(dsname)) if(dsnameValue == ""){ errorCondition(recall = StatMedImportRODBCtable, message = gettextRcmdr("You must enter the name of a data set.")) return() } if(!is.valid.name(dsnameValue)){ errorCondition(recall = StatMedImportRODBCtable, message = paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep = "")) return() } if(is.element(dsnameValue, listDataSets())){ if("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ importRODBCtable() return() } } File <- tclvalue(tkgetOpenFile(filetypes = gettextRcmdr( '{"All Files" {"*"}} {"MS Access database" {*.mdb ".MDB"}} {"MS Access 2007 database" {*.accdb ".ACCDB"}} {"dBase-like file" {*.dbf ".DBF"}} {"MS Excel file" {*.xls ".XLS" *.xlsx ".XLSX"}}' ))) if(File == ""){ tkfocus(CommanderWindow()) return() } sop <- match(".", rev(strsplit(File, NULL)[[1]]))[1] ext <- tolower(substring(File, nchar(File) - sop + 2, nchar(File))) channel <- switch(EXPR = ext, xls = odbcConnectExcel(File), xlsx = odbcConnectExcel2007(File), mdb = odbcConnectAccess(File), accdb = odbcConnectAccess2007(File), dbf = odbcConnectDbase(File)) # For Excel and Access cases, need to select a particular sheet or table if(ext != "dbf"){ tabdat <- sqlTables(channel) names(tabdat) <- tolower(names(tabdat)) if(ext == "mdb" || ext == "accdb") tabdat <- tabdat[tabdat$table_type == "TABLE", 3] if(ext == "xls" || ext == "xlsx"){ tabname <- tabdat$table_name tabdat <- ifelse(tabdat$table_type =="TABLE", substring(tabname, 2, nchar(tabname) - 2), substring(tabname, 1, nchar(tabname) - 1)) } # if there are several tables if(length(tabdat)>1) fil <- tk_select.list(sort(tabdat), title = gettextRcmdr("Select one table")) else fil <- tabdat if(fil == ""){ errorCondition(message=gettextRcmdr("No table selected")) return() } if(ext == "xls" || ext == "xlsx") fil <- paste("[", fil, "$]", sep = "") } # dBase file else{ sop <- match(".", rev(strsplit(File, NULL)[[1]]))[1] root <- tolower(substring(File, 1, nchar(File) - sop)) revstr <- rev(strsplit(root, NULL)[[1]]) sop <- if(is.na(match(c("/", "\\"), revstr)[1])) length(revstr) else match(c("/", "\\"), revstr)[1] - 1 toor <- revstr[seq(sop)] fil <- paste(rev(toor), collapse = "") } # Retrieve the data dat <- sqlQuery(channel = channel, query = paste("select * from", fil)) names(dat)<- trim.blanks(names(dat)) dat <- trim.col.na(dat) odbcCloseAll() gassign(dsnameValue, as.data.frame(dat)) command <- paste("sqlQuery(channel = ",channel,", select * from ", fil,")", sep = "") logger(paste(dsnameValue, " <- ", command, sep = "")) activeDataSet(dsnameValue) tkfocus(CommanderWindow()) } ## End of function onOK OKCancelHelp(helpSubject="odbcConnect") tkgrid(labelRcmdr(top, text=gettextRcmdr("Enter name of data set: ")), entryDsname, sticky="e") tkgrid(buttonsFrame, columnspan="2", sticky="w") tkgrid.configure(entryDsname, sticky="w") dialogSuffix(rows=2, columns=2, focus=entryDsname) } StatMedImportExcel <- function(){ Library("XLConnect") Library("methods") initializeDialog(title = gettextRcmdr("Import Excel Data Set")) dsname <- tclVar(gettextRcmdr("Dataset")) entryDsname <- ttkentry(top, width = "35", textvariable = dsname) onOK <- function(){ closeDialog() setBusyCursor() on.exit(setIdleCursor()) dsnameValue <- trim.blanks(tclvalue(dsname)) if(dsnameValue == ""){ errorCondition(recall = StatMedImportExcel, message = gettextRcmdr("You must enter the name of a data set.")) return() } if(!is.valid.name(dsnameValue)){ errorCondition(recall = StatMedImportExcel, message = paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep = "")) return() } if(is.element(dsnameValue, listDataSets())){ if("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ StatMedImportExcel() return() } } File <- tclvalue(tkgetOpenFile(filetypes = gettextRcmdr( '{{"MS Excel file" {".xls" ".XLS"}} "MS Excel 2007 file" {".xlsx" ".XLSX"}} {"All Files" {"*"}}' ), parent=CommanderWindow())) # File <- tclvalue(tkgetOpenFile(filetypes = gettextRcmdr( # '{"MS Excel 2007 file" {".xlsx" ".XLSX"}} {"MS Excel file" {".xls" ".XLS"}} {"All Files" {"*"}}' # ), parent=CommanderWindow())) if(File == ""){ tkfocus(CommanderWindow()) return() } command <- paste('loadWorkbook("', File, '")', sep="") doItAndPrint(paste(".Workbook <- ", command, sep="")) worksheets <- getSheets(.Workbook) if(length(worksheets)>1) worksheet <- tk_select.list(worksheets, title = gettextRcmdr("Select one table")) else worksheet <- worksheets if(worksheet == ""){ errorCondition(message=gettextRcmdr("No table selected")) return() } command <- paste('readWorksheet(.Workbook, "', worksheet, '")', sep="") logger(paste(dsnameValue, " <- ", command, sep="")) result <- justDoIt(command) if (class(result)[1] != "try-error"){ gassign(dsnameValue, result) } logger("remove(.Workbook)") justDoIt("remove(.Workbook, envir=.GlobalEnv)") if (class(result)[1] != "try-error"){ factors <- sapply(get(dsnameValue, envir=.GlobalEnv), is.character) if (any(factors)){ factors <- which(factors) command <- paste(dsnameValue, "[, c(", paste(factors, collapse=", "), ")] <- lapply(", dsnameValue, "[, c(", paste(factors, collapse=", "), "), drop=FALSE], as.factor)", sep="") doItAndPrint(command) } activeDataSet(dsnameValue) } } OKCancelHelp(helpSubject="readWorksheet") tkgrid(labelRcmdr(top, text=gettextRcmdr("Enter name of data set: ")), entryDsname, sticky="e") tkgrid(buttonsFrame, columnspan="2", sticky="w") tkgrid.configure(entryDsname, sticky="w") dialogSuffix(focus=entryDsname) } StatMedCopyDataset <- function(){ dataSets <- listDataSets() .activeDataSet <- ActiveDataSet() initializeDialog(title=gettextRcmdr( "Copy data set")) dsname <- tclVar("NewDataset") dsnameFrame <- tkframe(top) entryDsname <- ttkentry(dsnameFrame, width="20", textvariable=dsname) dataSet1Box <- variableListBox(top, dataSets, title=gettextRcmdr("Original Data Set"), initialSelection=if (is.null(.activeDataSet)) NULL else which(.activeDataSet == dataSets) - 1) onOK <- function(){ logger(paste("#####", gettextRcmdr("Copy data set"), "#####", sep="")) dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == getSelection(dataSet1Box)) { errorCondition(recall=StatMedCopyDataset, message=gettextRcmdr("You must enter a different data set name.")) return() } if (dsnameValue == "") { errorCondition(recall=StatMedCopyDataset, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=StatMedCopyDataset, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ closeDialog() StatMedCopyDataset() return() } } name1 <- getSelection(dataSet1Box) if (length(name1) == 0){ errorCondition(recall=StatMedCopyDataset, message=gettextRcmdr("You must select a data set.")) return() } command <- paste(dsnameValue, " <- ", name1, sep="") doItAndPrint(command) activeDataSet(dsnameValue) closeDialog() tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(labelRcmdr(dsnameFrame, text=gettextRcmdr("Name for new data set: ")), entryDsname) tkgrid(dsnameFrame, sticky="w", columnspan=2) tkgrid(getFrame(dataSet1Box), sticky="nw") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix() } StatMedRenameDataset <- function(){ dataSets <- listDataSets() .activeDataSet <- ActiveDataSet() initializeDialog(title=gettextRcmdr( "Rename data set")) dsname <- tclVar("NewName") dsnameFrame <- tkframe(top) entryDsname <- ttkentry(dsnameFrame, width="20", textvariable=dsname) dataSet1Box <- variableListBox(top, dataSets, title=gettextRcmdr("Original Data Set"), initialSelection=if (is.null(.activeDataSet)) NULL else which(.activeDataSet == dataSets) - 1) onOK <- function(){ logger(paste("#####", gettextRcmdr("Rename data set"), "#####", sep="")) dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == getSelection(dataSet1Box)) { errorCondition(recall=StatMedRenameDataset, message=gettextRcmdr("You must enter a different data set name.")) return() } if (dsnameValue == "") { errorCondition(recall=StatMedRenameDataset, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=StatMedRenameDataset, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ closeDialog() StatMedRenameDataset() return() } } name1 <- getSelection(dataSet1Box) if (length(name1) == 0){ errorCondition(recall=StatMedRenameDataset, message=gettextRcmdr("You must select a data set.")) return() } command <- paste(dsnameValue, " <- ", name1, sep="") doItAndPrint(command) activeDataSet(dsnameValue) command <- paste("remove(", name1, ")", sep="") doItAndPrint(command) activeDataSet(dsnameValue) closeDialog() tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(labelRcmdr(dsnameFrame, text=gettextRcmdr("New name for the data set: ")), entryDsname) tkgrid(dsnameFrame, sticky="w", columnspan=2) tkgrid(getFrame(dataSet1Box), sticky="nw") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix() } StatMedMergeDatasets <- function(){ dataSets <- listDataSets() .activeDataSet <- ActiveDataSet() initializeDialog(title=gettextRcmdr( "Merge data sets")) dsname <- tclVar("MergedDataset") dsnameFrame <- tkframe(top) entryDsname <- ttkentry(dsnameFrame, width="20", textvariable=dsname) dataSet1Box <- variableListBox(top, dataSets, title=gettextRcmdr("First Data Set (pick one)"), initialSelection=if (is.null(.activeDataSet)) NULL else which(.activeDataSet == dataSets) - 1) dataSet2Box <- variableListBox(top, dataSets, title=gettextRcmdr("Second Data Set (pick one)")) commonVar <- tclVar("0") commonFrame <- tkframe(top) commonButton <- ttkcheckbutton(commonFrame, variable=commonVar) radioButtons(top, "direction", buttons=c("rows", "columns"), labels=gettextRcmdr(c("Merge rows", "Merge columns")), title=gettextRcmdr("Direction of Merge")) radioButtons(top, "columnmerge", buttons=c("rownumber", "columns"), labels=gettextRcmdr(c("Merge by row number", "Merge by specified columns")), title=gettextRcmdr("Matching method to merge columns")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Merge data sets"), "#####", sep="")) dsnameValue <- trim.blanks(tclvalue(dsname)) if (dsnameValue == "") { errorCondition(recall=StatMedMergeDatasets, message=gettextRcmdr("You must enter the name of a data set.")) return() } if (!is.valid.name(dsnameValue)) { errorCondition(recall=StatMedMergeDatasets, message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsnameValue, listDataSets())) { if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){ closeDialog() StatMedMergeDatasets() return() } } name1 <- getSelection(dataSet1Box) name2 <- getSelection(dataSet2Box) if (length(name1) == 0){ errorCondition(recall=StatMedMergeDatasets, message=gettextRcmdr("You must select a data set.")) return() } if (length(name2) == 0){ errorCondition(recall=StatMedMergeDatasets, message=gettextRcmdr("You must select a data set.")) return() } if (name1 == name2){ errorCondition(recall=StatMedMergeDatasets, message=gettextRcmdr("You cannot merge a data set with itself.")) return() } common <- if (tclvalue(commonVar) == "1") TRUE else FALSE direction <- tclvalue(directionVariable) columnmerge <- tclvalue(columnmergeVariable) if (direction == "rows"){ command <- paste(dsnameValue, " <- mergeRows(", name1, ", ", name2, ", common.only=", common, ")", sep="") doItAndPrint(command) activeDataSet(dsnameValue) } else { if (columnmerge == "columns"){ command <- paste(dsnameValue, " <- NULL", sep="") doItAndPrint(command) initializeDialog(subdialog, title=gettextRcmdr("Columns to merge datasets")) onOKsub <- function() { column.name.1 <- getSelection(column1Box) column.name.2 <- getSelection(column2Box) if (length(column.name.1) == 0){ errorCondition(recall=NULL, message=gettextRcmdr("You must select two variables")) return() } if (length(column.name.2) == 0){ errorCondition(recall=NULL, message=gettextRcmdr("You must select two variables")) return() } closeDialog(subdialog) command <- paste(dsnameValue, " <- merge(", name1, ", ", name2, ", all=", !common, ', by.x="', column.name.1, '", by.y="', column.name.2, '")', sep="") doItAndPrint(command) activeDataSet(dsnameValue) } subOKCancelHelp() list1 <- listVariables(name1) list2 <- listVariables(name2) column1Box <- variableListBox(subdialog, list1, title=gettextRcmdr("Column name for matching in dataset 1(pick one)"), listHeight=10) column2Box <- variableListBox(subdialog, list2, title=gettextRcmdr("Column name for matching in dataset 2(pick one)"), listHeight=10) tkgrid(getFrame(column1Box), getFrame(column2Box), sticky="nw") tkgrid(subButtonsFrame, sticky="w", columnspan=2) dialogSuffix(subdialog, focus=subdialog, force.wait=TRUE) } else { command <- paste(dsnameValue, " <- merge(", name1, ", ", name2, ", all=", !common, ', by="row.names")', sep="") doItAndPrint(command) command <- paste("rownames(", dsnameValue, ") <- ", dsnameValue, "$Row.names", sep="") doItAndPrint(command) command <- paste(dsnameValue, "$Row.names <- NULL", sep="") doItAndPrint(command) activeDataSet(dsnameValue) } } closeDialog() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="mergeRows") tkgrid(labelRcmdr(dsnameFrame, text=gettextRcmdr("Name for merged data set: ")), entryDsname) tkgrid(dsnameFrame, sticky="w", columnspan=2) tkgrid(getFrame(dataSet1Box), getFrame(dataSet2Box), sticky="nw") tkgrid(commonButton, labelRcmdr(commonFrame, text=gettextRcmdr("Merge only common\nrows or columns")), sticky="nw") tkgrid(directionFrame, commonFrame, sticky="sw") tkgrid(columnmergeFrame, sticky="sw") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix() } StatMedSaveDataSet <- function() { logger(paste("#####", gettextRcmdr("Save active data set"), "#####", sep="")) if (activeDataSetP() == FALSE){ logger(gettextRcmdr("There is no active data set.")) return() } file <- tclvalue(tkgetSaveFile(filetypes= # gettextRcmdr('{"All Files" {"*"}} {"R Data Files" {".rda" ".Rda" ".RDA" ".RData"}}'), gettextRcmdr('{"R Data Files" {".rda" ".Rda" ".RDA" ".RData"}} {"All Files" {"*"}}'), defaultextension="rda", initialfile=paste(activeDataSet(), "rda", sep="."))) if (file == "") return() command <- paste('save("', activeDataSet(), '", file="', file, '")', sep="") justDoIt(command) logger(command) } StatMedExportDataSet <- function() { if (activeDataSetP() == FALSE){ logger(gettextRcmdr("There is no active data set.")) return() } logger(paste("#####", gettextRcmdr("Export active data set (Text)"), "#####", sep="")) dsname <- activeDataSet() initializeDialog(title=gettextRcmdr("Export Active Data Set")) checkBoxes(frame="optionsFrame", boxes=c("colnames", "rownames", "quotes"), initialValues=c(1,0,1), labels=gettextRcmdr(c("Write variable names:", "Write row names:", "Quotes around character values:"))) missingVariable <- tclVar("NA") missingEntry <- ttkentry(optionsFrame, width="8", textvariable=missingVariable) radioButtons(name="delimiter", buttons=c("spaces", "tabs", "commas"), labels=gettextRcmdr(c("Spaces", "Tabs", "Commas")), initialValue="commas", title=gettextRcmdr("Field Separator")) otherButton <- ttkradiobutton(delimiterFrame, variable=delimiterVariable, value="other") otherVariable <- tclVar("") otherEntry <- ttkentry(delimiterFrame, width="4", textvariable=otherVariable) onOK <- function(){ closeDialog() col <- tclvalue(colnamesVariable) == 1 row <- tclvalue(rownamesVariable) == 1 quote <- tclvalue(quotesVariable) == 1 delim <- tclvalue(delimiterVariable) missing <- tclvalue(missingVariable) sep <- if (delim == "tabs") "\\t" else if (delim == "spaces") " " else if (delim == "commas") "," else trim.blanks(tclvalue(otherVariable)) saveFile <- tclvalue(tkgetSaveFile(filetypes=gettextRcmdr('{"Text Files" {".txt" ".TXT" ".dat" ".DAT" ".csv" ".CSV"}} {"All Files" {"*"}}'), defaultextension="txt", initialfile=paste(dsname, ".txt", sep=""))) if (saveFile == "") { tkfocus(CommanderWindow()) return() } command <- paste("write.table(", dsname, ', "', saveFile, '", sep="', sep, '", col.names=', col, ", row.names=", row, ", quote=", quote, ', na="', missing, '")', sep="") justDoIt(command) logger(command) Message(paste(gettextRcmdr("Active dataset exported to file"), saveFile), type="note") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="write.table") tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Missing values:")), missingEntry, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(labelRcmdr(delimiterFrame, text=gettextRcmdr("Other")), otherButton, labelRcmdr(delimiterFrame, text=gettextRcmdr(" Specify:")), otherEntry, sticky="w") tkgrid(delimiterFrame, stick="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } StatMedExportStata <- function() { Library("foreign") Library("readstata13") if (activeDataSetP() == FALSE){ logger(gettextRcmdr("There is no active data set.")) return() } logger(paste("#####", gettextRcmdr("Export active data set (Stata)"), "#####", sep="")) dsname <- activeDataSet() initializeDialog(title=gettextRcmdr("Export Active Data Set")) optionsFrame <- tkframe(top) convertFactor <- tclVar("1") convertFactorCheckBox <- ttkcheckbutton(optionsFrame, variable=convertFactor) asDate <- tclVar("1") asDateCheckBox <- ttkcheckbutton(optionsFrame, variable=asDate) convertunderscore <- tclVar("1") convertunderscoreCheckBox <- ttkcheckbutton(optionsFrame, variable=convertunderscore) onOK <- function(){ closeDialog() convert.date <- tclvalue(asDate) == "1" convert.underscore <- tclvalue(convertunderscore) == "1" convert.factor <- tclvalue(convertFactor) == "1" # saveFile <- tclvalue(tkgetSaveFile(filetypes=gettextRcmdr('{"All Files" {"*"}} {"Stata datasets" {".dta" ".DTA"}}'), # defaultextension="", initialfile=paste(dsname, ".dta", sep=""))) saveFile <- tclvalue(tkgetSaveFile(filetypes=gettextRcmdr('{"Stata datasets" {".dta" ".DTA"}} {"All Files" {"*"}}'), defaultextension="", initialfile=paste(dsname, ".dta", sep=""))) if (saveFile == "") { tkfocus(CommanderWindow()) return() } # command <- paste("write.dta(", dsname, ', "', saveFile, '")', sep="") command <- paste("save.dta13(", dsname, ', "', saveFile, '", convert.factors=', convert.factor, ", convert.dates=", convert.date, ", convert.underscore=", convert.underscore, ')', sep="") #readstata13 package justDoIt(command) logger(command) Message(paste(gettextRcmdr("Active dataset exported to Stata file"), saveFile), type="note") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="write.dta") tkgrid(convertFactorCheckBox, labelRcmdr(optionsFrame, text=gettextRcmdr("Convert factors to Stata variables with labels"), justify="left"), sticky="nw") tkgrid(asDateCheckBox, labelRcmdr(optionsFrame, text=gettextRcmdr("Convert dates to Stata format"), justify="left"), sticky="w") tkgrid(convertunderscoreCheckBox, labelRcmdr(optionsFrame, text=gettextRcmdr("Convert non numerics or non alphabet characters to underscores"), justify="left"), sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } StatMedVariableCheck <- function(){ logger(paste("#####", gettextRcmdr("Show variables in active data set"), "#####", sep="")) command <- paste("str(", activeDataSet(), ")", sep="") doItAndPrint(command) invisible(NULL) } StatMedSubsetDataSet <- function(){ dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Subset Data Set")) allVariablesFrame <- tkframe(top) allVariables <- tclVar("1") allVariablesCheckBox <- tkcheckbutton(allVariablesFrame, variable=allVariables) variablesBox <- variableListBox(top, Variables(), selectmode="multiple", initialSelection=NULL, title=gettextRcmdr("Variables (select one or more)"), listHeight=10) subsetVariable <- tclVar(gettextRcmdr("<all cases>")) subsetFrame <- tkframe(top) subsetEntry <- ttkentry(subsetFrame, width="60", textvariable=subsetVariable) subsetScroll <- ttkscrollbar(subsetFrame, orient="horizontal", command=function(...) tkxview(subsetEntry, ...)) tkconfigure(subsetEntry, xscrollcommand=function(...) tkset(subsetScroll, ...)) newDataSetName <- tclVar(gettextRcmdr("<same as active data set>")) justshowVariablesFrame <- tkframe(top) justshowVariables <- tclVar("0") justshowVariablesCheckBox <- tkcheckbutton(justshowVariablesFrame, variable=justshowVariables) dataSetNameFrame <- tkframe(top) dataSetNameEntry <- ttkentry(dataSetNameFrame, width="25", textvariable=newDataSetName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Create subset data set"), "#####", sep="")) justshow <- tclvalue(justshowVariables) newName <- trim.blanks(tclvalue(newDataSetName)) if (newName == gettextRcmdr("<same as active data set>")) newName <- ActiveDataSet() if (!is.valid.name(newName)){ errorCondition(recall=StatMedSubsetDataSet, message=paste('"', newName, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (justshow==0 & is.element(newName, listDataSets())) { if ("no" == tclvalue(checkReplace(newName, type=gettextRcmdr("Data set")))){ closeDialog() StatMedSubsetDataSet() return() } } selectVars <- if (tclvalue(allVariables) == "1") "" else { x <- getSelection(variablesBox) if (0 > length(x)) { errorCondition(recall=StatMedSubsetDataSet, message=gettextRcmdr("No variables were selected.")) return() } paste(", select=c(", paste(x, collapse=","), ")", sep="") } closeDialog() cases <- tclvalue(subsetVariable) selectCases <- if (cases == gettextRcmdr("<all cases>")) "" else paste(", subset=", cases, sep="") if (selectVars == "" && selectCases ==""){ errorCondition(recall=StatMedSubsetDataSet, message=gettextRcmdr("New data set same as active data set.")) return() } if (justshow==0){ command <- paste(newName, " <- subset(", ActiveDataSet(), selectCases, selectVars, ")", sep="") logger(command) result <- justDoIt(command) if (class(result)[1] != "try-error") activeDataSet(newName) } else { command <- paste("subset(", ActiveDataSet(), selectCases, selectVars, ")", sep="") doItAndPrint(command) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="subset") tkgrid(labelRcmdr(allVariablesFrame, text=gettextRcmdr("Include all variables")), allVariablesCheckBox, sticky="w") tkgrid(allVariablesFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr(" OR"), fg="red"), sticky="w") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(labelRcmdr(subsetFrame, text=gettextRcmdr("Condition to extract samples")), sticky="w") tkgrid(labelRcmdr(subsetFrame, text=gettextRcmdr("Example 1: age>50 & Sex==0, Example 2: age<50 | Sex==1")), sticky="w") tkgrid(subsetEntry, sticky="w") tkgrid(subsetScroll, sticky="ew") tkgrid(subsetFrame, sticky="w") tkgrid(labelRcmdr(justshowVariablesFrame, text=gettextRcmdr("View data only (not create data set)")), justshowVariablesCheckBox, sticky="w") tkgrid(justshowVariablesFrame, sticky="w") tkgrid(labelRcmdr(dataSetNameFrame, text=gettextRcmdr("Name for new data set")), sticky="w") tkgrid(dataSetNameEntry, sticky="w") tkgrid(dataSetNameFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedRenameVariables <- function(){ initializeDialog(title=gettextRcmdr("Rename variables")) variableBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variables (pick one or more)"), selectmode="multiple", initialSelection=NULL, listHeight=10) onOK <- function(){ logger(paste("#####", gettextRcmdr("Rename variables"), "#####", sep="")) variables <- getSelection(variableBox) closeDialog() nvariables <- length(variables) if (nvariables < 1) { errorCondition(recall=renameVariables, message=gettextRcmdr("No variables selected.")) return() } .activeDataSet <- ActiveDataSet() unordered.names <- names(get(.activeDataSet)) # unordered.names <- names(eval(parse(text=.activeDataSet))) which.variables <- match(variables, unordered.names) initializeDialog(subdialog, title=gettextRcmdr("Variable Names")) newnames <- rep("", nvariables) onOKsub <- function() { closeDialog(subdialog) for (i in 1:nvariables){ newnames[i] <- eval(parse(text=paste("tclvalue(newName", i, ")", sep=""))) } if (any(newnames == "")){ errorCondition(recall=renameVariables, message=gettextRcmdr("A variable name is empty.")) return() } test.names <- newnames == make.names(newnames) if (!all(test.names)){ errorCondition(recall=renameVariables, message=paste(gettextRcmdr("The following variable names are not valid:\n"), paste(newnames[!test.names], collapse=", "))) return() } all.names <- names(get(.activeDataSet)) # all.names <- eval(parse(text=paste("names(", .activeDataSet, ")"))) all.names[which.variables] <- newnames if (length(unique(all.names)) != length(all.names)){ errorCondition(recall=renameVariables, message=gettextRcmdr("Variable names are not unique")) return() } command <- paste("names(", .activeDataSet, ")[c(", paste(which.variables, collapse=","), ")] <- c(", paste('"', newnames, '"', collapse=",", sep=""), ")", sep="") result <- justDoIt(command) logger(command) if (class(result)[1] != "try-error") activeDataSet(.activeDataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } subOKCancelHelp() tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Old Name"), fg="blue"), labelRcmdr(subdialog, text=gettextRcmdr("New name"), fg="blue"), sticky="w") for (i in 1:nvariables){ valVar <- paste("newName", i, sep="") assign(valVar, tclVar("")) assign(paste("entry", i, sep=""), ttkentry(subdialog, width="20", # textvariable=eval(parse(text=valVar)))) textvariable=get(valVar))) tkgrid(labelRcmdr(subdialog, text=variables[i]), get(paste("entry", i, sep="")), sticky="w") # tkgrid(labelRcmdr(subdialog, text=variables[i]), eval(parse(text=paste("entry", i, sep=""))), sticky="w") } tkgrid(subButtonsFrame, sticky="w", columnspan=2) dialogSuffix(subdialog, rows=nvariables+2, columns=2, focus=entry1, onOK=onOKsub, force.wait=TRUE) } OKCancelHelp(helpSubject="names") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } StatMedDeleteVariable <- function(){ dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Delete variables from data set")) variablesBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variable(s) to delete (pick one or more)"), selectmode="multiple", initialSelection=NULL, listHeight=15) onOK <- function(){ logger(paste("#####", gettextRcmdr("Delete variables from data set"), "#####", sep="")) variables <- getSelection(variablesBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=StatMedDeleteVariable, message=gettextRcmdr("You must select one or more variables.")) return() } if (length(variables) == 1){ response <- tclvalue(RcmdrTkmessageBox(message=sprintf(gettextRcmdr("Delete %s?\nPlease confirm."), variables), icon="warning", type="okcancel", default="cancel")) if (response == "cancel") { onCancel() return() } } else{ response <- tclvalue(RcmdrTkmessageBox(message= sprintf(gettextRcmdr("Delete %d variables?\nPlease confirm."), length(variables)), icon="warning", type="okcancel", default="cancel")) if (response == "cancel") { onCancel() return() } } for (variable in variables){ eval(parse(text=paste(dataSet, "$", variable, "<- NULL", sep="")), envir=.GlobalEnv) logger(paste(dataSet, "$", variable, " <- NULL", sep="")) } activeDataSet(dataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="NULL") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } StatMedStack <- function(){ initializeDialog(title=gettextRcmdr("Stack variables to long format data set")) variableBox <- variableListBox(top, Variables(), selectmode="multiple", title=gettextRcmdr("Variables (pick two or more)"), listHeight=10) factorName <- tclVar("") factorNameField <- ttkentry(top, width="20", textvariable=factorName) variableName <- tclVar("") variableNameField <- ttkentry(top, width="20", textvariable=variableName) datasetName <- tclVar("") datasetNameField <- ttkentry(top, width="20", textvariable=datasetName) checkBoxes(frame="checkboxFrame", boxes=c("othervar"), initialValues=c(1),labels=gettextRcmdr(c("Include other variables in new data set"))) # subsetBox(model=TRUE) StatMedSubsetBox() onOK <- function(){ logger(paste("#####", gettextRcmdr("Stack variables to long format data set"), "#####", sep="")) variables <- getSelection(variableBox) facname <- tclvalue(factorName) varname <- tclvalue(variableName) dsname <- tclvalue(datasetName) othervar <- tclvalue(othervarVariable) closeDialog() if (length(variables) < 2) { errorCondition(recall=StatMedStack, message=gettextRcmdr("You must select at least two variables.")) return() } if (!is.valid.name(facname)){ errorCondition(recall=StatMedStack, message=paste('"', facname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (!is.valid.name(varname)){ errorCondition(recall=StatMedStack, message=paste('"', varname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (!is.valid.name(dsname)){ errorCondition(recall=Stack, message=paste('"', dsname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(dsname, listDataSets())) { if ("no" == tclvalue(checkReplace(dsname, gettextRcmdr("Data set")))){ Stack() return() } } # command <- paste(dsname, " <- stack(", activeDataSet(), "[, c(", # paste(paste('"', variables, '"', sep=""), collapse=","), ")])", sep="") # logger(command) # result <- justDoIt(command) # command <- paste("names(", dsname, ') <- c("', varname, '", "', facname, '")', # sep="") # logger(command) # justDoIt(command) dataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { doItAndPrint(paste("TempDF <- ", dataSet)) } else { doItAndPrint(paste("TempDF <- subset(", dataSet, ",", subset, ")") ) } nvar <- length(variables) # RepeatedData <- variables[1] # RepeatedData2 <- paste('"', variables[1], '"', sep="") # for(i in 2:nvar){ # RepeatedData <- paste(RepeatedData, ", ", variables[i], sep="") # RepeatedData2 <- paste(RepeatedData2, ', "', variables[i], '"', sep="") # } logger("#Convert to long format") doItAndPrint("n <- length(TempDF[,1])") # doItAndPrint("TempDF$TempIDforReshaping <- c(1:n)") if(othervar==0){ command <- paste("TempDF <- data.frame(", variables[1], "=TempDF$", variables[1], sep="") for (i in 2:nvar){ command <- paste(command, ", ", variables[i], "=TempDF$", variables[i], sep="") } command <- paste(command, ")", sep="") doItAndPrint(command) } # command <- paste('TempDF2 <- reshape(TempDF, idvar="TempIDforReshaping", varying=list(c("', variables[1], sep="") command <- paste('TempDF2 <- reshape(TempDF, varying=list(c("', variables[1], sep="") for (i in 2:nvar){ command <- paste(command, '", "', variables[i], sep="") } command <- paste(command, '")), v.names="', varname, '", timevar="', facname, '", direction="long")', sep="") doItAndPrint(command) command <- paste('RepeatNumber <- c("', variables[1], sep="") for (i in 2:nvar){ command <- paste(command, '", "', variables[i], sep="") } command <- paste(command, '")', sep="") doItAndPrint(command) doItAndPrint(paste("TempDF2$", facname, " <- RepeatNumber[TempDF2$", facname, "]", sep="")) # doItAndPrint("TempDF2$TempIDforReshaping <- NULL") result <- doItAndPrint(paste(dsname, " <- TempDF2", sep="")) if (class(result)[1] != "try-error") activeDataSet(dsname) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="stack") tkgrid(getFrame(variableBox), sticky="nw", columnspan=2) tkgrid(labelRcmdr(top, text="")) tkgrid(labelRcmdr(top, text=gettextRcmdr("Name for stacked data set:")), datasetNameField, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Name for stacked variable data in new data set:")), variableNameField, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Name for factor to identify stacked variables in new data set:")), factorNameField, sticky="w") tkgrid(checkboxFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=5, columns=2, preventGrabFocus=TRUE) } StatMedSort <- function(){ initializeDialog(title=gettextRcmdr("Sort rows")) variablesBox <- variableListBox(top, Variables(), initialSelection=NULL, title=gettextRcmdr("Variable for sorting"), listHeight=10) optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="decreasing", buttons=gettextRcmdr(c("Ascending", "Descending")), values=c("FALSE", "TRUE"), labels=gettextRcmdr(c("Ascending", "Descending")), title=gettextRcmdr("Sorting order")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Sort rows"), "#####", sep="")) dataSet <- activeDataSet() x <- getSelection(variablesBox) if (length(x) == 0) { errorCondition(recall=StatMedSort, message=gettextRcmdr("You must select a variable.")) return() } closeDialog() decreasing <- tclvalue(decreasingVariable) command <- paste("TempList <- order(", dataSet, "$", x, ", decreasing=", decreasing, ")", sep="") doItAndPrint(command) command <- paste(dataSet, " <- ", dataSet, "[TempList,]", sep="") logger(command) result <- justDoIt(command) if (class(result)[1] != "try-error") activeDataSet(dataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="order") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(decreasingFrame, labelRcmdr(optionsFrame, text=" "), sticky="nw") tkgrid(optionsFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedCountMissing <- function(){ initializeDialog(title=gettextRcmdr("Count missing observations of specified variables")) variableBox <- variableListBox(top, Variables(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)"), listHeight=15) onOK <- function(){ logger(paste("#####", gettextRcmdr("Count missing observations of specified variables"), "#####", sep="")) variables <- getSelection(variableBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=StatMedCountMissing, message=gettextRcmdr("You must select a variable.")) return() } .activeDataSet <- ActiveDataSet() for (name in variables){ command <- paste("sum(is.na(", .activeDataSet, "$", name, ")) ###", name, gettextRcmdr(": Number of missing observations"), sep="") doItAndPrint(command) } } OKCancelHelp(helpSubject="is.na") tkgrid(labelRcmdr(top, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=4, columns=2, preventGrabFocus=TRUE) } StatMedFilterNA <- function(){ dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Remove rows with missing data in specified variables")) variablesBox <- variableListBox(top, Variables(), selectmode="multiple", initialSelection=NULL, title=gettextRcmdr("Variables to remove rows with missing data (pick one or more)"), listHeight=15) newDataSetName <- tclVar(gettextRcmdr("<same as active data set>")) dataSetNameFrame <- tkframe(top) dataSetNameEntry <- ttkentry(dataSetNameFrame, width="25", textvariable=newDataSetName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Remove rows with missing data in specified variables"), "#####", sep="")) x <- getSelection(variablesBox) closeDialog() newName <- trim.blanks(tclvalue(newDataSetName)) .activeDataSet <- ActiveDataSet() if (newName == gettextRcmdr("<same as active data set>")) newName <- .activeDataSet if (!is.valid.name(newName)){ errorCondition(recall=StatMedFilterNA, message=paste('"', newName, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(newName, listDataSets())) { if ("no" == tclvalue(checkReplace(newName, gettextRcmdr("Data set")))){ filterNA() return() } } if (length(x) == 0) { errorCondition(recall=StatMedFilterNA, message=gettextRcmdr("No variables were selected.")) return() } command <- paste(newName, " <- ", .activeDataSet, "[complete.cases(", .activeDataSet, "$", x[1], sep="") if (length(x)>1){ for (i in 2:length(x)){ command <- paste(command, ", ", .activeDataSet, "$", x[i], sep="") } } command <- paste(command, "),]", sep="") logger(command) result <- justDoIt(command) if (class(result)[1] != "try-error") activeDataSet(newName) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="complete.cases") tkgrid(labelRcmdr(top, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(labelRcmdr(dataSetNameFrame, text=gettextRcmdr("Name for new data set")), sticky="w") tkgrid(dataSetNameEntry, sticky="w") tkgrid(dataSetNameFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedNAgroup <- function(){ initializeDialog(title=gettextRcmdr("Convert missing observations to a group")) dataSet <- activeDataSet() variablesBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variable including missing data"), listHeight=15) newVariableName <- tclVar("") newVariableNameEntry <- ttkentry(top, width="20", textvariable=newVariableName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Convert missing observations to a group"), "#####", sep="")) var <- trim.blanks(getSelection(variablesBox)) if (length(var) == 0){ errorCondition(recall=StatMedNAgroup, message=gettextRcmdr("You must select a variable.")) return() } newVar <- trim.blanks(tclvalue(newVariableName)) if (!is.valid.name(newVar)){ errorCondition(recall=StatMedNAgroup, message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (newVar == var){ errorCondition(recall=StatMedNAgroup, message=gettextRcmdr("New variable name must be different from the original name.")) return() } closeDialog() command <- paste("if(sum(is.na(", dataSet, "$", var, "))>0) ", dataSet,"$",newVar, " <- as.factor(ifelse(is.na(", dataSet, "$", var, '), "NA", as.character(', dataSet, "$", var, ")))", sep="") result <- doItAndPrint(command) command <- paste("if(sum(is.na(", dataSet, "$", var, '))==0) cat(gettextRcmdr("There was no missing data."), "\n")', sep="") result <- doItAndPrint(command) if (class(result)[1] != "try-error") activeDataSet(dataSet, flushModel=FALSE) doItAndPrint(paste("if(sum(is.na(", dataSet, "$", var, '))>0) cat(gettextRcmdr("New variable"), "', newVar, '", gettextRcmdr("was made."), "\n")', sep="") ) doItAndPrint(paste("if(sum(is.na(", dataSet, "$", var, "))>0) table(", dataSet, "$", newVar, ")", sep="") ) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="is.na") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(tklabel(top, text=gettextRcmdr("New variable name")), newVariableNameEntry, sticky="w") tkgrid.configure(newVariableNameEntry, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=3, columns=2) } StatMedNewVar <- function(){ initializeDialog(title=gettextRcmdr("Bin numeric variable with specified threshold")) dataSet <- activeDataSet() variablesBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Select one numeric variable"), listHeight=15) newVariableName <- tclVar("") newVariableNameEntry <- ttkentry(top, width="20", textvariable=newVariableName) threshold <- tclVar("") thresholdEntry <- ttkentry(top, width="20", textvariable=threshold) radioButtons(name="grouping", buttons=c("equalgreater", "greater"), values=c(">=", ">"), labels=gettextRcmdr(c(">= (equal to or greater than)", "> (greater than)")), title=gettextRcmdr("Threshold")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Bin numeric variable with specified threshold"), "#####", sep="")) var <- trim.blanks(getSelection(variablesBox)) if (length(var) == 0){ errorCondition(recall=StatMedNewVar, message=gettextRcmdr("You must select a variable.")) return() } newVar <- trim.blanks(tclvalue(newVariableName)) if (!is.valid.name(newVar)){ errorCondition(recall=StatMedNewVar, message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } threshold <- tclvalue(threshold) if (length(threshold) == 0){ errorCondition(recall=StatMedNewVar, message=gettextRcmdr("Input threshold to bin a numeric variable.")) return() } grouping <- as.character(tclvalue(groupingVariable)) closeDialog() command <- paste(dataSet,"$",newVar, " <- ifelse(", dataSet, "$", var, grouping, threshold, ", 1 , 0)", sep="") logger(command) result <- justDoIt(command) if (class(result)[1] != "try-error") activeDataSet(dataSet, flushModel=FALSE) # logger(paste("#", gettextRcmdr("New variable"), " ", newVar, " ", gettextRcmdr("was made."), "(", threshold, gettextRcmdr("<=:1, >:0"), sep="") ) logger(paste("#", gettextRcmdr("New variable"), " ", newVar, " ", gettextRcmdr("was made."), sep="") ) doItAndPrint(paste("table(", dataSet, "$", newVar, ", exclude=NULL)", sep="") ) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="ifelse") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(tklabel(top, text=gettextRcmdr("New variable name")), newVariableNameEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Threshold to bin a numeric variable.")), thresholdEntry, sticky="w") tkgrid.configure(newVariableNameEntry, sticky="w") tkgrid.configure(thresholdEntry, sticky="w") tkgrid(groupingFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=3, columns=2) } StatMedNewVar2 <- function(){ initializeDialog(title=gettextRcmdr("Bin numeric variable to more than 2 groups with specified thresholds")) dataSet <- activeDataSet() variablesBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Select one numeric variable"), listHeight=15) thresholdFrame <- tkframe(top) newVariableNameFrame <- tkframe(thresholdFrame) newVariableNameVariable <- tclVar("") newVariableNameField <- ttkentry(thresholdFrame, width="20", textvariable=newVariableNameVariable) threshold1Frame <- tkframe(thresholdFrame) threshold1Variable <- tclVar("") threshold1Field <- ttkentry(thresholdFrame, width="10", textvariable=threshold1Variable) threshold2Frame <- tkframe(thresholdFrame) threshold2Variable <- tclVar("") threshold2Field <- ttkentry(thresholdFrame, width="10", textvariable=threshold2Variable) threshold3Frame <- tkframe(thresholdFrame) threshold3Variable <- tclVar("") threshold3Field <- ttkentry(thresholdFrame, width="10", textvariable=threshold3Variable) threshold4Frame <- tkframe(thresholdFrame) threshold4Variable <- tclVar("") threshold4Field <- ttkentry(thresholdFrame, width="10", textvariable=threshold4Variable) threshold5Frame <- tkframe(thresholdFrame) threshold5Variable <- tclVar("") threshold5Field <- ttkentry(thresholdFrame, width="10", textvariable=threshold5Variable) levelname1Frame <- tkframe(thresholdFrame) levelname1Variable <- tclVar("<no group>") levelname1Field <- ttkentry(thresholdFrame, width="20", textvariable=levelname1Variable) levelname2Frame <- tkframe(thresholdFrame) levelname2Variable <- tclVar("<no group>") levelname2Field <- ttkentry(thresholdFrame, width="20", textvariable=levelname2Variable) levelname3Frame <- tkframe(thresholdFrame) levelname3Variable <- tclVar("<no group>") levelname3Field <- ttkentry(thresholdFrame, width="20", textvariable=levelname3Variable) levelname4Frame <- tkframe(thresholdFrame) levelname4Variable <- tclVar("<no group>") levelname4Field <- ttkentry(thresholdFrame, width="20", textvariable=levelname4Variable) levelname5Frame <- tkframe(thresholdFrame) levelname5Variable <- tclVar("<no group>") levelname5Field <- ttkentry(thresholdFrame, width="20", textvariable=levelname5Variable) levelname6Frame <- tkframe(thresholdFrame) levelname6Variable <- tclVar("<no group>") levelname6Field <- ttkentry(thresholdFrame, width="20", textvariable=levelname6Variable) radioButtons(name="grouping", buttons=c("equalgreater", "greater"), values=c(">=", ">"), labels=gettextRcmdr(c(">= (equal to or greater than)", "> (greater than)")), title=gettextRcmdr("Threshold")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Bin numeric variable to more than 2 groups with specified thresholds"), "#####", sep="")) var <- trim.blanks(getSelection(variablesBox)) if (length(var) == 0){ errorCondition(recall=StatMedNewVar2, message=gettextRcmdr("You must select a variable.")) return() } newVar <- trim.blanks(tclvalue(newVariableNameVariable)) if (!is.valid.name(newVar)){ errorCondition(recall=StatMedNewVar2, message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } threshold1 <- tclvalue(threshold1Variable) threshold2 <- tclvalue(threshold2Variable) threshold3 <- tclvalue(threshold3Variable) threshold4 <- tclvalue(threshold4Variable) threshold5 <- tclvalue(threshold5Variable) levelname1 <- tclvalue(levelname1Variable) levelname2 <- tclvalue(levelname2Variable) levelname3 <- tclvalue(levelname3Variable) levelname4 <- tclvalue(levelname4Variable) levelname5 <- tclvalue(levelname5Variable) levelname6 <- tclvalue(levelname6Variable) grouping <- as.character(tclvalue(groupingVariable)) if(grouping==">="){ right <- ", right=FALSE)" } else { right <- ", right=TRUE)" } levels <- 0 breaks <- ", breaks=c(-Inf, " labels <- ", labels=c(" if (levelname1 == "<no group>"){ errorCondition(recall=StatMedNewVar2, message=gettextRcmdr("Input at least two groups.")) return() } else { levels <- levels + 1 labels <- paste(labels, '"', levelname1, '"', sep="") } if (levelname2 != "<no group>"){ if (length(threshold1) == 0){ errorCondition(recall=StatMedNewVar2, message=gettextRcmdr("Input threshold to bin a numeric variable.")) return() } levels <- levels + 1 breaks <- paste(breaks, threshold1, sep="") labels <- paste(labels, ', "', levelname2, '"', sep="") } if (levelname3 != "<no group>"){ if (length(threshold2) == 0){ errorCondition(recall=StatMedNewVar2, message=gettextRcmdr("Input threshold to bin a numeric variable.")) return() } levels <- levels + 1 breaks <- paste(breaks, ", ", threshold2, sep="") labels <- paste(labels, ', "', levelname3, '"', sep="") } if (levelname4 != "<no group>"){ if (length(threshold3) == 0){ errorCondition(recall=StatMedNewVar2, message=gettextRcmdr("Input threshold to bin a numeric variable.")) return() } levels <- levels + 1 breaks <- paste(breaks, ", ", threshold3, sep="") labels <- paste(labels, ', "', levelname4, '"', sep="") } if (levelname5 != "<no group>"){ if (length(threshold4) == 0){ errorCondition(recall=StatMedNewVar2, message=gettextRcmdr("Input threshold to bin a numeric variable.")) return() } levels <- levels + 1 breaks <- paste(breaks, ", ", threshold4, sep="") labels <- paste(labels, ', "', levelname5, '"', sep="") } if (levelname6 != "<no group>"){ if (length(threshold5) == 0){ errorCondition(recall=StatMedNewVar2, message=gettextRcmdr("Input threshold to bin a numeric variable.")) return() } levels <- levels + 1 breaks <- paste(breaks, ", ", threshold5, sep="") labels <- paste(labels, ', "', levelname6, '"', sep="") } if (levels < 2){ errorCondition(recall=StatMedNewVar2, message=gettextRcmdr("Input at least two groups.")) return() } breaks <- paste(breaks, ", Inf)", sep="") labels <- paste(labels, ")", sep="") closeDialog() command <- paste(dataSet,"$",newVar, " <- cut(", dataSet, "$", var, breaks, labels, right, sep="") logger(command) result <- justDoIt(command) if (class(result)[1] != "try-error") activeDataSet(dataSet, flushModel=FALSE) logger(paste("#", gettextRcmdr("New variable"), " ", newVar, " ", gettextRcmdr("was made."), sep="") ) doItAndPrint(paste("table(", dataSet, "$", newVar, ", exclude=NULL)", sep="") ) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="ifelse") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(labelRcmdr(newVariableNameFrame, text=gettextRcmdr("New variable name:")), newVariableNameField, sticky = "w") tkgrid(newVariableNameFrame, labelRcmdr(thresholdFrame, text=" "), sticky="w") tkgrid(labelRcmdr(thresholdFrame, text=gettextRcmdr("Input thresholds and level names."), fg="blue"), sticky="w") tkgrid(labelRcmdr(levelname1Frame, text=paste(gettextRcmdr("Level group name"), " 1:", sep="")), levelname1Field, sticky = "w") tkgrid(levelname1Frame, labelRcmdr(thresholdFrame, text=" "), sticky="w") tkgrid(labelRcmdr(levelname2Frame, text=paste(gettextRcmdr("Level group name"), " 2:", sep="")), levelname2Field, sticky = "w") tkgrid(labelRcmdr(threshold1Frame, text=paste(gettextRcmdr("Threshold"), " 1:", sep="")), threshold1Field, sticky = "w") tkgrid(levelname2Frame, labelRcmdr(thresholdFrame, text=" "), threshold1Frame, sticky="w") tkgrid(labelRcmdr(levelname3Frame, text=paste(gettextRcmdr("Level group name"), " 3:", sep="")), levelname3Field, sticky = "w") tkgrid(labelRcmdr(threshold2Frame, text=paste(gettextRcmdr("Threshold"), " 2:", sep="")), threshold2Field, sticky = "w") tkgrid(levelname3Frame, labelRcmdr(thresholdFrame, text=" "), threshold2Frame, sticky="w") tkgrid(labelRcmdr(levelname4Frame, text=paste(gettextRcmdr("Level group name"), " 4:", sep="")), levelname4Field, sticky = "w") tkgrid(labelRcmdr(threshold3Frame, text=paste(gettextRcmdr("Threshold"), " 3:", sep="")), threshold3Field, sticky = "w") tkgrid(levelname4Frame, labelRcmdr(thresholdFrame, text=" "), threshold3Frame, sticky="w") tkgrid(labelRcmdr(levelname5Frame, text=paste(gettextRcmdr("Level group name"), " 5:", sep="")), levelname5Field, sticky = "w") tkgrid(labelRcmdr(threshold4Frame, text=paste(gettextRcmdr("Threshold"), " 4:", sep="")), threshold4Field, sticky = "w") tkgrid(levelname5Frame, labelRcmdr(thresholdFrame, text=" "), threshold4Frame, sticky="w") tkgrid(labelRcmdr(levelname6Frame, text=paste(gettextRcmdr("Level group name"), " 6:", sep="")), levelname6Field, sticky = "w") tkgrid(labelRcmdr(threshold5Frame, text=paste(gettextRcmdr("Threshold"), " 5:", sep="")), threshold5Field, sticky = "w") tkgrid(levelname6Frame, labelRcmdr(thresholdFrame, text=" "), threshold5Frame, sticky="w") tkgrid(thresholdFrame, sticky="w") tkgrid(groupingFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=3, columns=2) } StatMedCompute <- function(){ onDoubleClick <-function(){ var <- trim.blanks(getSelection(variablesBox)) word <- paste("\\[", gettextRcmdr("factor"), "\\]", sep="") if (length(grep(word, var)) == 1) var <- trim.blanks(sub(word, "", var)) tkfocus(compute) expr <- tclvalue(computeVar) tclvalue(computeVar) <- if (expr == "") var else paste(expr, var, sep=if (rev(strsplit(expr, "")[[1]])[1] =="(" ) "" else " ") tkicursor(compute, "end") tkxview.moveto(compute, "1") } dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Create new variable")) .variables <- Variables() variables <- paste(.variables, ifelse(is.element(.variables, Factors()), gettextRcmdr("[factor]"), "")) variablesBox <- variableListBox(top, variables, title=gettextRcmdr("Current variables (double-click to expression)"), listHeight=15) tkbind(variablesBox$listbox, "<Double-ButtonPress-1>", onDoubleClick) variablesFrame <- tkframe(top) newVariableName <- tclVar(gettextRcmdr("variable")) newVariable <- ttkentry(variablesFrame, width="20", textvariable=newVariableName) computeFrame <- tkframe(top) computeVar <- tclVar("") compute <- ttkentry(computeFrame, font=getRcmdr("logFont"), width="60", textvariable=computeVar) computeXscroll <- ttkscrollbar(computeFrame, orient="horizontal", command=function(...) tkxview(compute, ...)) tkconfigure(compute, xscrollcommand=function(...) tkset(computeXscroll, ...)) onOK <- function(){ logger(paste("#####", gettextRcmdr("Create new variable"), "#####", sep="")) closeDialog() newVar <- trim.blanks(tclvalue(newVariableName)) if (!is.valid.name(newVar)){ errorCondition(recall=StatMedCompute, message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } express <- tclvalue(computeVar) check.empty <- gsub(";", "", gsub(" ", "", express)) if ("" == check.empty) { errorCondition(recall=StatMedCompute, message=gettextRcmdr("No expression specified.")) return() } if (is.element(newVar, Variables())) { if ("no" == tclvalue(checkReplace(newVar, gettextRcmdr("Variable")))){ StatMedCompute() return() } } command <- paste(dataSet,"$",newVar, " <- with(", ActiveDataSet(), ", ", express, ")", sep="") logger(command) result <- justDoIt(command) if (class(result)[1] != "try-error") activeDataSet(dataSet, flushModel=FALSE) logger(paste("#", gettextRcmdr("New variable"), " ", newVar, " ", gettextRcmdr("was made."), sep="") ) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="ifelse") tkgrid(getFrame(variablesBox), sticky="nw", columnspan=2) tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("New variable name")), sticky="w") tkgrid(newVariable, labelRcmdr(variablesFrame, text=" "), sticky="w") tkgrid(labelRcmdr(computeFrame, text=gettextRcmdr("Expression to compute")), sticky="w") tkgrid(compute, sticky="w") tkgrid(computeXscroll, sticky="ew") tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Example 1: ifelse(age > 50 & Sex == 0, 1, 0)")), sticky="w") tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Example 2: ifelse(age < 50 | Sex == 1, 1, 0)")), sticky="w") tkgrid(variablesFrame, sticky="nw") tkgrid(computeFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=3, columns=2, focus=compute) } StatMedLog <- function(){ initializeDialog(title=gettextRcmdr("Logarithmic transformation")) variableBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)"), listHeight=15) radioButtons(name="base", buttons=c("common", "natural", "binary"), values=c("10", "exp(1)", "2"), labels=gettextRcmdr(c("Common logarithm (base=10)", "Natural logarithm (base=e)", "Binary logarithm (base=2)")), title=gettextRcmdr("Base of logarithmic transformation")) logName <- tclVar(gettextRcmdr("<same as variables>")) logNameField <- ttkentry(top, width="20", textvariable=logName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Logarithmic transformation"), "#####", sep="")) variables <- getSelection(variableBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=StatMedLog, message=gettextRcmdr("You must select a variable.")) return() } logname <- trim.blanks(tclvalue(logName)) base <- as.character(tclvalue(baseVariable)) .activeDataSet <- ActiveDataSet() for (name in variables){ lname <- if (logname == gettextRcmdr("<same as variables>")) name else if (length(variables) == 1) logname else paste(logname, name, sep="") if (!is.valid.name(lname)){ errorCondition(recall=StatMedLog, message=paste('"', lname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(lname, Variables())) { if ("no" == tclvalue(checkReplace(lname))){ StatMedLog() return() } } command <- paste(.activeDataSet, "$", lname, " <- log(", .activeDataSet, "$", name, ", base=", base, ")", sep="") result <- justDoIt(command) logger(command) if (class(result)[1] != "try-error") activeDataSet(.activeDataSet, flushModel=FALSE) logger(paste("#", gettextRcmdr("New variable"), " ", lname, " ", gettextRcmdr("was made."), sep="") ) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="log") tkgrid(getFrame(variableBox), baseFrame, sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("New variable name or prefix for multiple variables:")), logNameField, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=4, columns=2, preventGrabFocus=TRUE) } StatMedNumericToFactor <- function(){ initializeDialog(title=gettextRcmdr("Convert Numeric Variables to Factors")) variableBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)"), listHeight=15) radioButtons(name="levels", buttons=c("names", "numbers"), labels=gettextRcmdr(c("Supply level names", "Use numbers")), title=gettextRcmdr("Factor Levels")) factorName <- tclVar(gettextRcmdr("<same as variables>")) factorNameField <- ttkentry(top, width="20", textvariable=factorName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Convert numeric variables to factors"), "#####", sep="")) variables <- getSelection(variableBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=StatMedNumericToFactor, message=gettextRcmdr("You must select a variable.")) return() } facname <- trim.blanks(tclvalue(factorName)) .activeDataSet <- ActiveDataSet() cmd <- paste("apply(", .activeDataSet, "[c(", paste( paste('"', variables, '"', sep=""), collapse=","), ")], 2, function(x) sort(unique(x)))", sep="") levs <- eval(parse(text=cmd), envir=.GlobalEnv) sameLevels <- (length(variables) == 1) || ((is.matrix(levs)) && (all(0 == apply(levs, 1, var)))) for (name in variables){ fname <- if (facname == gettextRcmdr("<same as variables>")) name else if (length(variables) == 1) facname else paste(facname, name, sep="") if (!is.valid.name(fname)){ errorCondition(recall=StatMedNumericToFactor, message=paste('"', fname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(fname, Variables())) { if ("no" == tclvalue(checkReplace(fname))){ StatMedNumericToFactor() return() } } levelsType <- tclvalue(levelsVariable) env <- environment() if (((name == variables[1]) || (!sameLevels)) && (levelsType == "names")){ values <- sort(unique(eval(parse(text=paste(.activeDataSet, "$", name, sep="")), envir=.GlobalEnv))) nvalues <- length(values) if (nvalues > 30) { errorCondition(recall=StatMedNumericToFactor, message=sprintf(gettextRcmdr("Number of levels (%d) too large."), nvalues)) return() } initializeDialog(subdialog, title=paste(gettextRcmdr("Level Names for"), if(sameLevels && length(variables) > 1) "Factors" else fname)) names <- rep("", nvalues) onOKsub <- function() { closeDialog(subdialog) for (i in 1:nvalues){ names[i] <- eval(parse(text=paste("tclvalue(levelName", i, ")", sep=""))) } if (length(unique(names)) != nvalues){ errorCondition(recall=StatMedNumericToFactor, message=gettextRcmdr("Levels names are not unique.")) return() } if (any(names == "")){ errorCondition(recall=StatMedNumericToFactor, message=gettextRcmdr("A level name is empty.")) return() } assign("labels", paste(paste("'", names, "'", sep=""), collapse=","), envir=env) } subOKCancelHelp() tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Numeric value")), labelRcmdr(subdialog, text=gettextRcmdr("Level name")), sticky="w") for (i in 1:nvalues){ valVar <- paste("levelName", i, sep="") assign(valVar, tclVar("")) assign(paste("entry", i, sep=""), ttkentry(subdialog, width="20", textvariable=get(valVar))) # textvariable=eval(parse(text=valVar)))) tkgrid(labelRcmdr(subdialog, text=values[i]), get(paste("entry", i, sep="")), sticky="w") # tkgrid(labelRcmdr(subdialog, text=values[i]), eval(parse(text=paste("entry", i, sep=""))), sticky="w") } tkgrid(subButtonsFrame, sticky="w", columnspan=2) dialogSuffix(subdialog, rows=nvalues+2, columns=2, focus=entry1, onOK=onOKsub, force.wait=TRUE) } if (levelsType == "names"){ if (!exists("labels", mode="character")) return() command <- paste("factor(", .activeDataSet, "$", name, ", labels=c(", labels, "))", sep="") result <- justDoIt(paste(.activeDataSet, "$", fname, " <- ", command, sep="")) logger(paste(.activeDataSet,"$", fname," <- ", command, sep="")) if (class(result)[1] != "try-error") activeDataSet(.activeDataSet) tkfocus(CommanderWindow()) } else{ command <- paste("as.factor(", .activeDataSet, "$", name, ")", sep="") result <- justDoIt(paste(.activeDataSet, "$", fname, " <- ", command, sep="")) logger(paste(.activeDataSet, "$", fname," <- ", command, sep="")) if (class(result)[1] != "try-error") activeDataSet(.activeDataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } } } OKCancelHelp(helpSubject="factor") tkgrid(getFrame(variableBox), levelsFrame, sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("New variable name or prefix for multiple variables:")), factorNameField, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) tkgrid.configure(numbersButton, sticky="w") tkgrid.configure(namesButton, sticky="w") dialogSuffix(rows=4, columns=2, preventGrabFocus=TRUE) } StatMedBinVariable <- function(){ # Author: Dan Putler (revision by J. Fox, 2 Feb 05) # if (!checkActiveDataSet()) return() # if (!checkNumeric()) return() env <- environment() initializeDialog(title=gettextRcmdr("Bin a Numeric Variable")) variableFrame <- tkframe(top) variableBox <- variableListBox(variableFrame, Numeric(), title=gettextRcmdr("Variable to bin (pick one)"), listHeight=15) newVariableFrame <- tkframe(variableFrame) newVariableName <- tclVar(gettextRcmdr("variable")) newVariable <- ttkentry(newVariableFrame, width="18", textvariable=newVariableName) binsFrame <- tkframe(top) binsVariable <- tclVar("3") slider <- tkscale(binsFrame, from=2, to=20, showvalue=TRUE, variable=binsVariable, resolution=1, orient="horizontal") optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="levels", buttons=c("specify", "numbers", "ranges"), labels=gettextRcmdr(c("Specify names", "Numbers", "Ranges")), title=gettextRcmdr("Level Names")) radioButtons(optionsFrame, name="method", buttons=c("intervals", "proportions", "natural"), labels=gettextRcmdr(c("Equal-width bins", "Equal-count bins", "Natural breaks\n(from K-means clustering)")), title=gettextRcmdr("Binning Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Bin a Numeric Variable"), "#####", sep="")) levels <- tclvalue(levelsVariable) bins <- as.numeric(tclvalue(binsVariable)) varName <- getSelection(variableBox) closeDialog() if (length(varName) == 0){ errorCondition(recall=StatMedBinVariable, message=gettextRcmdr("You must select a variable.")) return() } newVar <- tclvalue(newVariableName) if (is.element(newVar, Variables())) { if ("no" == tclvalue(checkReplace(newVar))){ binVariable() return() } } if (!is.valid.name(newVar)){ errorCondition(message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep=""), recall=StatMedBinVariable) return() } method <- tclvalue(methodVariable) if (levels == "specify"){ initializeDialog(subdialog, title=gettextRcmdr("Bin Names")) onOKsub <- function() { closeDialog(subdialog) level <- character(bins) for (i in 1:bins){ level[i] <- eval(parse(text=paste("tclvalue(levelName", i, ")", sep=""))) } if (length(unique(level)) != length(level)){ errorCondition(window=subdialog, message=gettextRcmdr("Level names must be unique."), recall=onOK) return() } assign("levelNames", level, envir=env) } subOKCancelHelp() tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Bin"), fg="blue"), labelRcmdr(subdialog, text=gettextRcmdr("Name"), fg="blue"), sticky="w") for (i in 1:bins){ valVar <- paste("levelName", i, sep="") assign(valVar, tclVar(i)) assign(paste("entry", i, sep=""), ttkentry(subdialog, width="20", textvariable=get(valVar))) # textvariable=eval(parse(text=valVar)))) tkgrid(labelRcmdr(subdialog, text=as.character(i)), get(paste("entry", i, sep="")), sticky="w") # tkgrid(labelRcmdr(subdialog, text=as.character(i)), eval(parse(text=paste("entry", i, sep=""))), sticky="w") } tkgrid(subButtonsFrame, sticky="w", columnspan=2) dialogSuffix(subdialog, focus=entry1, rows=bins+1, columns=2, bindReturn=FALSE, force.wait=TRUE) } labels <- if (levels == "numbers") "FALSE" else if (levels == "ranges") "NULL" else { if (!exists("levelNames")){ onCancel() binVariable() return() } paste("c('", paste(levelNames, collapse="','"), "')", sep="") } .activeDataSet <- ActiveDataSet() command <- paste(.activeDataSet,"$",newVar, " <- ", "bin.var(", .activeDataSet,"$", varName, ", bins=", bins, ", method=", "'", method, "', labels=", labels, ")", sep="") logger(command) result <- justDoIt(command) if (class(result)[1] != "try-error") activeDataSet(.activeDataSet, flushModel=FALSE) logger(paste("#", gettextRcmdr("New variable"), " ", newVar, " ", gettextRcmdr("was made."), sep="") ) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="bin.var") tkgrid(labelRcmdr(newVariableFrame, text=gettextRcmdr("New variable name"), fg="blue"), sticky="w") tkgrid(newVariable, sticky="w") tkgrid(getFrame(variableBox), labelRcmdr(variableFrame, text=" "), newVariableFrame, sticky="nw") tkgrid(variableFrame, sticky="w") tkgrid(labelRcmdr(binsFrame, text=gettextRcmdr("Number of bins:")), slider, sticky="s") tkgrid(binsFrame, sticky="w") tkgrid(levelsFrame, labelRcmdr(optionsFrame, text=" "), methodFrame, sticky="nw") tkgrid(optionsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedFactorToNumeric <- function(){ initializeDialog(title=gettextRcmdr("Convert factors or character variables of numeric data to numeric variables")) variableBox <- variableListBox(top, Variables(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)"), listHeight=15) factorName <- tclVar(gettextRcmdr("<same as variables>")) factorNameField <- ttkentry(top, width="20", textvariable=factorName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Convert factors or character variables of numeric data to numeric variables"), "#####", sep="")) variables <- getSelection(variableBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=StatMedFactorToNumeric, message=gettextRcmdr("You must select a variable.")) return() } facname <- trim.blanks(tclvalue(factorName)) .activeDataSet <- ActiveDataSet() cmd <- paste("apply(", .activeDataSet, "[c(", paste( paste('"', variables, '"', sep=""), collapse=","), ")], 2, function(x) sort(unique(x)))", sep="") for (name in variables){ fname <- if (facname == gettextRcmdr("<same as variables>")) name else if (length(variables) == 1) facname else paste(facname, name, sep="") if (!is.valid.name(fname)){ errorCondition(recall=StatMedFactorToNumeric, message=paste('"', fname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(fname, Variables())) { if ("no" == tclvalue(checkReplace(fname))){ numericToFactor() return() } } command <- paste("as.numeric(as.character(", .activeDataSet, "$", name, "))", sep="") result <- justDoIt(paste(.activeDataSet, "$", fname, " <- ", command, sep="")) logger(paste(.activeDataSet, "$", fname," <- ", command, sep="")) if (class(result)[1] != "try-error") activeDataSet(.activeDataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } } OKCancelHelp(helpSubject="numeric") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("New variable name or prefix for multiple variables:")), factorNameField, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=4, columns=2, preventGrabFocus=TRUE) } StatMedReorderFactor <- function(){ initializeDialog(title=gettextRcmdr("Reorder Factor Levels")) variableBox <- variableListBox(top, Factors(), title=gettextRcmdr("Factor (pick one)"), listHeight=15) orderedFrame <- tkframe(top) orderedVariable <- tclVar("0") orderedCheckBox <- tkcheckbutton(orderedFrame, variable=orderedVariable) factorName <- tclVar(gettextRcmdr("<same as original>")) factorNameField <- ttkentry(top, width="20", textvariable=factorName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Reorder Factor Levels"), "#####", sep="")) variable <- getSelection(variableBox) closeDialog() if (length(variable) == 0) { errorCondition(recall=StatMedReorderFactor, message=gettextRcmdr("You must select a variable.")) return() } name <- trim.blanks(tclvalue(factorName)) if (name == gettextRcmdr("<same as original>")) name <- variable if (!is.valid.name(name)){ errorCondition(recall=StatMedReorderFactor, message=paste('"', name, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(name, Variables())) { if ("no" == tclvalue(checkReplace(name))){ reorderFactor() return() } } .activeDataSet <- ActiveDataSet() old.levels <- eval(parse(text=paste("levels(", .activeDataSet, "$", variable, ")", sep="")), envir=.GlobalEnv) nvalues <- length(old.levels) ordered <- tclvalue(orderedVariable) if (nvalues > 30) { errorCondition(recall=StatMedReorderFactor, message=sprintf(gettextRcmdr("Number of levels (%d) too large."), nvalues)) return() } initializeDialog(subdialog, title=gettextRcmdr("Reorder Levels")) order <- 1:nvalues onOKsub <- function() { closeDialog(subdialog) opt <- options(warn=-1) for (i in 1:nvalues){ order[i] <- as.numeric(eval(parse(text=paste("tclvalue(levelOrder", i, ")", sep="")))) } options(opt) if (any(sort(order) != 1:nvalues) || any(is.na(order))){ errorCondition(recall=StatMedReorderFactor, message=paste(gettextRcmdr("Order of levels must include all integers from 1 to "), nvalues, sep="")) return() } levels <- old.levels[order(order)] ordered <- if (ordered == "1") ", ordered=TRUE" else "" command <- paste("factor(", .activeDataSet, "$", variable, ", levels=c(", paste(paste("'", levels, "'", sep=""), collapse=","), ")", ordered, ")", sep="") result <- justDoIt(paste(.activeDataSet, "$", name, " <- ", command, sep="")) logger(paste(.activeDataSet,"$", name," <- ", command, sep="")) if (class(result)[1] != "try-error") activeDataSet(.activeDataSet, flushModel=FALSE) } subOKCancelHelp() tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Old Levels"), fg="blue"), labelRcmdr(subdialog, text=gettextRcmdr("New order"), fg="blue"), sticky="w") for (i in 1:nvalues){ valVar <- paste("levelOrder", i, sep="") assign(valVar, tclVar(i)) assign(paste("entry", i, sep=""), ttkentry(subdialog, width="2", textvariable=get(valVar))) # textvariable=eval(parse(text=valVar)))) tkgrid(labelRcmdr(subdialog, text=old.levels[i]), get(paste("entry", i, sep="")), sticky="w") # tkgrid(labelRcmdr(subdialog, text=old.levels[i]), eval(parse(text=paste("entry", i, sep=""))), sticky="w") } tkgrid(subButtonsFrame, sticky="w", columnspan=2) dialogSuffix(subdialog, focus=entry1, rows=nvalues+1, columns=2, force.wait=TRUE) } OKCancelHelp(helpSubject="factor") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("Name for factor")), sticky="w") tkgrid(factorNameField, sticky="w") tkgrid(labelRcmdr(orderedFrame, text=gettextRcmdr("Make ordered factor")), orderedCheckBox, sticky="w") tkgrid(orderedFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1, preventGrabFocus=TRUE) } StatMedDropUnusedFactorLevels <- function(){ dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Drop Unused Factor Levels")) allfactorsVariable <- tclVar("0") allFrame <- tkframe(top) allfactorsCheckBox <- ttkcheckbutton(allFrame, variable = allfactorsVariable) variablesBox <- variableListBox(top, Factors(), title=gettextRcmdr("Factors(s) to drop levels (pick one or more)"), selectmode="multiple", initialSelection=NULL) onOK <- function(){ logger(paste("#####", gettextRcmdr("Drop unused factor levels"), "#####", sep="")) all <- tclvalue(allfactorsVariable) variables <- getSelection(variablesBox) closeDialog() if (all == 0 && length(variables) == 0) { errorCondition(recall=StatMedDropUnusedFactorLevels, message=gettextRcmdr("You must select one or more variables.")) return() } response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("Drop unused factor levels\nPlease confirm."), icon="warning", type="okcancel", default="cancel")) if (response == "cancel") { onCancel() return() } if (all == 1) command <- paste(dataSet, " <- droplevels(", dataSet, ")", sep="") else{ command <- "" for (variable in variables){ command <- paste(command, dataSet, "$", variable, " <- droplevels(", dataSet, "$", variable, ")\n", sep="") } } doItAndPrint(command) activeDataSet(dataSet, flushModel=FALSE, flushDialogMemory=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="droplevels") tkgrid(allfactorsCheckBox, labelRcmdr(allFrame, text=gettextRcmdr("all factors")), sticky="w") tkgrid(allFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("OR"), fg="red"), sticky="w") tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix() } StatMedRecodeDialog <- function () { processRecode <- function(recode) { parts <- strsplit(recode, "=")[[1]] if (length(grep(",", parts[1])) > 0) paste("c(", parts[1], ") = ", parts[2], sep = "") else paste(parts, collapse = "=") } dataSet <- activeDataSet() defaults <- list (initial.asFactor = 1, initial.variables = NULL, initial.name = "variable", initial.recode.directives="") dialog.values <- getDialog ("StatMedRecodeDialog", defaults) initializeDialog(title = gettextRcmdr("Recode Variables")) variablesBox <- variableListBox(top, Variables(), selectmode = "multiple", title = gettextRcmdr("Variables to recode (pick one or more)"), initialSelection = varPosn (dialog.values$initial.variables, "all")) variablesFrame <- tkframe(top) newVariableName <- tclVar(dialog.values$initial.name) newVariable <- ttkentry(variablesFrame, width = "20", textvariable = newVariableName) recodesFrame <- tkframe(top) recodes <- tktext(recodesFrame, bg = "white", font = getRcmdr("logFont"), height = "5", width = "40", wrap = "none") recodesXscroll <- ttkscrollbar(recodesFrame, orient = "horizontal", command = function(...) tkxview(recodes, ...)) recodesYscroll <- ttkscrollbar(recodesFrame, command = function(...) tkyview(recodes, ...)) tkconfigure(recodes, xscrollcommand = function(...) tkset(recodesXscroll, ...)) tkconfigure(recodes, yscrollcommand = function(...) tkset(recodesYscroll, ...)) tkinsert(recodes, "1.0", dialog.values$initial.recode.directives) asFactorFrame <- tkframe(top) asFactorVariable <- tclVar(dialog.values$initial.asFactor) asFactorCheckBox <- ttkcheckbutton(asFactorFrame, variable = asFactorVariable) onOK <- function() { logger(paste("#####", gettextRcmdr("Recode variables"), "#####", sep="")) Library("tcltk") ### <- Library("tcltk") required in EZR to avoid "tkget" error asFactor <- tclvalue(asFactorVariable) == "1" save.recodes <- trim.blanks(tclvalue(tkget(recodes, "1.0", "end"))) recode.directives <- gsub("\n", "; ", save.recodes) check.empty <- gsub(";", "", gsub(" ", "", recode.directives)) if ("" == check.empty) { errorCondition(recall = StatMedRecodeDialog, message = gettextRcmdr("No recode directives specified.")) return() } if (0 != length(grep("'", recode.directives))) { errorCondition(recall = StatMedRecodeDialog, message = gettextRcmdr("Use only double-quotes (\" \") in recode directives")) return() } recode.directives <- strsplit(recode.directives, ";")[[1]] recode.directives <- paste(sapply(recode.directives, processRecode), collapse = ";") recode.directives <- sub(" *; *$", "", recode.directives) variables <- getSelection(variablesBox) closeDialog() if (length(variables) == 0) { errorCondition(recall = StatMedRecodeDialog, message = gettextRcmdr("You must select a variable.")) return() } multiple <- if (length(variables) > 1) TRUE else FALSE name <- trim.blanks(tclvalue(newVariableName)) # save.recodes <- gsub("; ", "\\\n", trim.blanks(recode.directives)) putDialog ("StatMedRecodeDialog", list (initial.asFactor = asFactor, initial.variables = variables, initial.name = name, initial.recode.directives=save.recodes)) command <- paste(dataSet, " <- within(", dataSet, ", {", sep="") nvar <- length(variables) for (i in 1:nvar) { variable <- variables[nvar - i + 1] newVar <- if (multiple) paste(name, variable, sep = "") else name if (!is.valid.name(newVar)) { errorCondition(recall = StatMedRecodeDialog, message = paste("\"", newVar, "\" ", gettextRcmdr("is not a valid name."), sep = "")) return() } if (is.element(newVar, Variables())) { if ("no" == tclvalue(checkReplace(newVar))) { StatMedRecodeDialog() return() } } command <- paste(command, "\n ", newVar, " <- Recode(", variable, ", '", recode.directives, "', as.factor=", asFactor, ")", sep = "") } command <- paste(command, "\n})", sep="") result <- doItAndPrint(command) if (class(result)[1] != "try-error") activeDataSet(dataSet, flushModel = FALSE, flushDialogMemory = FALSE) # else{ # if (getRcmdr("use.markdown")) removeLastRmdBlock() # if (getRcmdr("use.knitr")) removeLastRnwBlock() # } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject = "StatMedRecodeDialog", reset = "StatMedRecodeDialog", apply = "StatMedRecodeDialog") tkgrid(getFrame(variablesBox), sticky = "nw") tkgrid(labelRcmdr(variablesFrame, text = "")) tkgrid(labelRcmdr(variablesFrame, text = gettextRcmdr("New variable name or prefix for multiple recodes: ")), newVariable, sticky = "w") tkgrid(asFactorCheckBox, labelRcmdr(asFactorFrame, text = gettextRcmdr("Make (each) new variable a factor")), sticky = "w") tkgrid(labelRcmdr(asFactorFrame, text = "")) tkgrid(labelRcmdr(recodesFrame, text = gettextRcmdr("Enter recode directives"), fg = getRcmdr("title.color"), font="RcmdrTitleFont"), sticky = "w") tkgrid(recodes, recodesYscroll, sticky = "nw") tkgrid(recodesXscroll) tkgrid(variablesFrame, sticky = "w") tkgrid(asFactorFrame, sticky = "w") tkgrid(recodesFrame, sticky = "w") tkgrid(buttonsFrame, sticky = "w", columnspan = 2) tkgrid.configure(recodesXscroll, sticky = "ew") tkgrid.configure(recodesYscroll, sticky = "ns") dialogSuffix(bindReturn = FALSE) } StatMedSetContrasts <- function(){ initializeDialog(title=gettextRcmdr("Define contrasts for a factor")) variableBox <- variableListBox(top, Factors(), title=gettextRcmdr("Factor (pick one)"), listHeight=15) radioButtons(name="contrasts", buttons=c("treatment", "sum", "helmert", "poly", "specify"), values=c("contr.Treatment", "contr.Sum", "contr.helmert", "contr.poly", "specify"), labels=gettextRcmdr(c("Treatment (dummy) contrasts", "Sum (deviation) contrasts", "Helmert contrasts", "Polynomial contrasts", "Other (specify)")), title=gettextRcmdr("Contrasts")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Define contrasts for a factor"), "#####", sep="")) variable <- getSelection(variableBox) closeDialog() if (length(variable) == 0) { errorCondition(recall=StaMedSetContrasts, message=gettextRcmdr("You must select a variable.")) return() } contrasts <- tclvalue(contrastsVariable) if (contrasts != "specify"){ command <- paste("contrasts(", ActiveDataSet(), "$", variable, ') <- "', contrasts, '"', sep="") result <- justDoIt(command) logger(command) if (class(result)[1] != "try-error") activeDataSet(ActiveDataSet()) tkfocus(CommanderWindow()) } else{ initializeDialog(subdialog, title=gettextRcmdr("Specify Contrasts")) tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Enter Contrast Coefficients"), fg="blue"), sticky="w") env <- environment() tableFrame <- tkframe(subdialog) row.names <- eval(parse(text=paste("levels(", ActiveDataSet(), "$", variable, ")"))) row.names <- substring(paste(abbreviate(row.names, 12), " "), 1, 12) nrows <- length(row.names) ncols <- nrows - 1 make.col.names <- paste("labelRcmdr(tableFrame, text='", gettextRcmdr("Contrast Name:"), "')", sep="") for (j in 1:ncols) { varname <- paste(".col.", j, sep="") assign(varname, tclVar(paste(".", j, sep="")), envir=env) make.col.names <- paste(make.col.names, ", ", "ttkentry(tableFrame, width='12', textvariable=", varname, ")", sep="") } eval(parse(text=paste("tkgrid(", make.col.names, ", sticky='w')", sep="")), envir=env) for (i in 1:nrows){ make.row <- paste("labelRcmdr(tableFrame, text='", row.names[i], "')") for (j in 1:ncols){ varname <- paste(".tab.", i, ".", j, sep="") assign(varname, tclVar("0"), envir=env) make.row <- paste(make.row, ", ", "ttkentry(tableFrame, width='5', textvariable=", varname, ")", sep="") } eval(parse(text=paste("tkgrid(", make.row, ", sticky='w')", sep="")), envir=env) } tkgrid(tableFrame, sticky="w") onOKsub <- function(){ closeDialog(subdialog) cell <- 0 values <- rep(NA, nrows*ncols) for (j in 1:ncols){ for (i in 1:nrows){ cell <- cell + 1 varname <- paste(".tab.", i, ".", j, sep="") values[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep="")))) } } values <- na.omit(values) if (length(values) != nrows*ncols){ errorCondition(subdialog, recall=StatMedSetContrasts, message=sprintf(gettextRcmdr( "Number of valid entries in contrast matrix(%d)\nnot equal to number of levels (%d) * number of contrasts (%d)."), length(values), nrows, ncols)) return() } if (qr(matrix(values, nrows, ncols))$rank < ncols) { errorCondition(subdialog, recall=StatMedSetContrasts, message=gettextRcmdr("Contrast matrix is not of full column rank")) return() } contrast.names <- rep("", ncols) for (j in 1:ncols){ varname <- paste(".col.", j, sep="") contrast.names[j] <- eval(parse(text=paste("tclvalue(", varname,")", sep=""))) } if (length(unique(contrast.names)) < ncols) { errorCondition(subdialog, recall=StatMedSetContrasts, message=gettextRcmdr("Contrast names must be unique")) return() } command <- paste("matrix(c(", paste(values, collapse=","), "), ", nrows, ", ", ncols, ")", sep="") # assign(".Contrasts", justDoIt(command), envir=.GlobalEnv) # logger(paste(".Contrasts <- ", command, sep="")) doItAndPrint(paste(".Contrasts <- ", command, sep="")) command <- paste("colnames(.Contrasts) <- c(", paste("'", contrast.names, "'", sep="", collapse=", "), ")", sep="") justDoIt(command) logger(command) command <- paste("contrasts(", ActiveDataSet(), "$", variable, ") <- .Contrasts", sep="") result <- justDoIt(command) logger(command) justDoIt("remove(.Contrasts, envir=.GlobalEnv)") logger("remove(.Contrasts)") if (class(result)[1] != "try-error") activeDataSet(ActiveDataSet(), flushModel=FALSE) tkfocus(CommanderWindow()) } subOKCancelHelp(helpSubject="contrasts") tkgrid(tableFrame, sticky="w") tkgrid(labelRcmdr(subdialog, text="")) tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subdialog, rows=5, columns=1, focus=subdialog, force.wait=TRUE) } } OKCancelHelp(helpSubject="contrasts") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(contrastsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedDummy <- function(){ initializeDialog(title=gettextRcmdr("Create dummy variables")) dataSet <- activeDataSet() variablesBox <- variableListBox(top, Variables(), title=gettextRcmdr("Select one variable to make dummy variables"), listHeight=15) newVariableName <- tclVar(".Dummy.") newVariableNameEntry <- ttkentry(top, width="20", textvariable=newVariableName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Create dummy variables"), "#####", sep="")) var <- trim.blanks(getSelection(variablesBox)) if (length(var) == 0){ errorCondition(recall=StatMedDummy, message=gettextRcmdr("You must select a variable.")) return() } newVar <- trim.blanks(tclvalue(newVariableName)) if (newVar == ""){ errorCondition(recall=StatMedDummy, message=gettextRcmdr("Define characters to indentify dummy variables")) return() } closeDialog() groups <- eval(parse(text=paste("levels(factor(", ActiveDataSet(), "$", var, "))", sep=""))) ngroups <- length(groups) for (i in 1:ngroups) { newvarname <- paste(var, newVar, groups[i], sep="") for(j in 1:nchar(newvarname)){ char <- substring(newvarname, j, j) substring(newvarname, j, j) <- ifelse(char=="/" | char=="*" | char=="-" | char=="+" | char==" " | char=="(" | char==")", ".", char) } if (!is.valid.name(newvarname)){ errorCondition(recall=StatMedDummy, message=paste('"', newvarname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } command <- paste(ActiveDataSet(), "$", newvarname, " <- ifelse(", ActiveDataSet(), "$", var, '=="', groups[i], '", 1, 0)', sep="") result <- justDoIt(command) logger(command) logger(paste("###", gettextRcmdr("Dummy variable"), " ", newvarname, " ", gettextRcmdr("was made."), sep="")) doItAndPrint(paste("table(", ActiveDataSet(), "$", newvarname, ", exclude=NULL)", sep="") ) } if (class(result)[1] != "try-error") activeDataSet(ActiveDataSet(), flushModel=FALSE) logger(gettextRcmdr("Input all dummy variables except for the referece group into the model.")) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(getFrame(variablesBox), sticky="nw") tkgrid(tklabel(top, text=gettextRcmdr("Characters to identify dummy variables")), newVariableNameEntry, sticky="w") tkgrid.configure(newVariableNameEntry, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=3, columns=2) } StatMedDatediff <- function(){ initializeDialog(title=gettextRcmdr("Compute difference between two date variables")) dataSet <- activeDataSet() startBox <- variableListBox(top, title=gettextRcmdr("Select start date"), listHeight=12) stopBox <- variableListBox(top, title=gettextRcmdr("Select end date"), listHeight=12) newVariableName <- tclVar("") newVariableNameEntry <- ttkentry(top, width="20", textvariable=newVariableName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Compute difference between two date variables"), "#####", sep="")) start <- trim.blanks(getSelection(startBox)) stop <- trim.blanks(getSelection(stopBox)) if (length(start) == 0 || length(stop) == 0){ errorCondition(recall=StatMedDatediff, message=gettextRcmdr("You must select two variables.")) return() } newVar <- trim.blanks(tclvalue(newVariableName)) if (!is.valid.name(newVar)){ errorCondition(recall=StatMedDatediff, message=paste('"', newVar, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } ymd <- as.character(tclvalue(ymdVariable)) switch(ymd, "a" = ymd <- ', "%Y-%m-%d"', "b" = ymd <- ', "%Y/%m/%d"', "c" = ymd <- ', "%y-%m-%d"', "d" = ymd <- ', "%y/%m/%d"', "e" = ymd <- ', "%m-%d-%Y"', "f" = ymd <- ', "%m/%d/%Y"', "g" = ymd <- ', "%m-%d-%y"', "h" = ymd <- ', "%m/%d/%Y"', ) closeDialog() command <- paste(dataSet,"$",newVar, " <- with(", dataSet, ", as.numeric(as.Date(", stop, ymd,") - as.Date(", start, ymd,")))", sep="") logger(command) result <- justDoIt(command) if (class(result)[1] != "try-error") activeDataSet(dataSet, flushModel=FALSE) logger(paste("#", gettextRcmdr("New variable"), " ", newVar, " ", gettextRcmdr("was made."), sep="") ) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="as.Date") radioButtons(name="ymd", buttons=c("A", "B", "C", "D", "E", "F", "G", "H"), values=c("a", "b", "c", "d", "e", "f", "g", "h"), initialValue="a", labels=c("1999-12-31", "1999/12/31", "99-12-31", "99/12/31", "12-31-1999", "12/31/1999", "12-31-99", "12/31/99"), title=gettextRcmdr("Select format")) tkgrid(ymdFrame, sticky="w") tkgrid(getFrame(startBox), getFrame(stopBox), sticky="nw") tkgrid(tklabel(top, text=gettextRcmdr("New variable name"), fg="blue"), newVariableNameEntry, sticky="w") tkgrid.configure(newVariableNameEntry, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=3, columns=2) } StatMedRenewDataSet <- function(){ initializeDialog(title=gettextRcmdr("Renew active data set")) checkBoxes(frame="chrtofac", boxes=c("chrtofac"),initialValues=c(1),labels=gettextRcmdr("Convert all character variables to factors")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Renew active data set"), "#####", sep="")) dataSet <- activeDataSet() chrtofac <- tclvalue(chrtofacVariable) closeDialog() if(chrtofac==1){ doItAndPrint(paste(dataSet, " <- ChrToFactor(", dataSet, ")", sep="")) } activeDataSet(dataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="factor") tkgrid(labelRcmdr(top, text=gettextRcmdr("Renew currently active data set"), fg="blue"), sticky="w") tkgrid(chrtofac, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedChrToFactor <- function(){ initializeDialog(title=gettextRcmdr("Convert all character variables to factors")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Convert all character variables to factors"), "#####", sep="")) dataSet <- activeDataSet() closeDialog() doItAndPrint(paste(dataSet, " <- ChrToFactor(", dataSet, ")", sep="")) activeDataSet(dataSet, flushModel=FALSE) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="factor") tkgrid(labelRcmdr(top, text=gettextRcmdr("Convert all character variables to factors."), fg="blue"), sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedGraphOptions <- function(){ defaults <- list(window.size="Medium", window.type="width=7, height=7", lwd="1", las="1", family="sans", cex="1") dialog.values <- getDialog("StatMedGraphOptions", defaults) initializeDialog(title=gettextRcmdr("Graph settings")) optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="window.size", buttons=gettextRcmdr(c("Small", "Medium", "Large")), values=c("Small", "Medium", "Large"), initialValue=dialog.values$window.size, labels=gettextRcmdr(c("Small", "Medium", "Large")), title=gettextRcmdr("Graph size")) radioButtons(optionsFrame, name="window.type", buttons=gettextRcmdr(c("Square", "Horizontal", "Vertical")), values=c("width=7, height=7", "width=9, height=6", "width=6, height=9"), initialValue=dialog.values$window.type, labels=gettextRcmdr(c("Square", "Horizontal rectangle", "Vertical rectangle")), title=gettextRcmdr("Graph shape")) radioButtons(optionsFrame, name="lwd", buttons=gettextRcmdr(c("Thin", "Medium", "Thick")), values=c("1", "2", "3"), initialValue=dialog.values$lwd, labels=gettextRcmdr(c("Thin", "Medium", "Thick")), title=gettextRcmdr("Line width")) radioButtons(optionsFrame, name="las", buttons=gettextRcmdr(c("ParallelAxis", "Horizontal", "PerpendicularAxis", "Vertical")), values=c("0", "1", "2", "3"), initialValue=dialog.values$las, labels=gettextRcmdr(c("Parallel to axis", "Horizontal", "Perpendicular to axis", "Vertical")), title=gettextRcmdr("Axis label style")) radioButtons(optionsFrame, name="family", buttons=c("standard", "sans", "serif", "mono"), values=c("", "sans", "serif", "mono"), initialValue=dialog.values$family, labels=gettextRcmdr(c("Standard", "Sans", "Serif", "Mono")), title=gettextRcmdr("Font")) radioButtons(optionsFrame, name="cex", buttons=gettextRcmdr(c("Small", "Medium", "Large")), values=c("1", "1.25", "1.5"), initialValue=dialog.values$cex, labels=gettextRcmdr(c("Small", "Medium", "Large")), title=gettextRcmdr("Font size")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Graph settings"), "#####", sep="")) # doItAndPrint('unlockBinding("lwd", as.environment("package:RcmdrPlugin.EZR"))') # doItAndPrint('unlockBinding("lwd", as.environment("package:Rcmdr"))') # justDoIt('unlockBinding("las", as.environment("package:RcmdrPlugin.EZR"))') # justDoIt('unlockBinding("font", as.environment("package:RcmdrPlugin.EZR"))') # justDoIt('unlockBinding("cex", as.environment("package:RcmdrPlugin.EZR"))') # justDoIt('unlockBinding("window.type", as.environment("package:RcmdrPlugin.EZR"))') # justDoIt('unlockBinding("par.option", as.environment("package:RcmdrPlugin.EZR"))') size <- tclvalue(window.sizeVariable) type <- tclvalue(window.typeVariable) lwd <- tclvalue(lwdVariable) las <- tclvalue(lasVariable) font <- tclvalue(familyVariable) cex <- tclvalue(cexVariable) putDialog("StatMedGraphOptions", list(window.size=size, window.type=type, lwd=lwd, las=las, family=font, cex=cex)) closeDialog() if (size=="Medium"){ switch(type, # "width=7, height=7" = window.type <<- "width=10.5, height=10.5", # "width=9, height=6" = window.type <<- "width=13.5, height=9", # "width=6, height=9" = window.type <<- "width=9, height=13.5" # "width=7, height=7" = assign("window.type", "width=10.5, height=10.5", envir=.GlobalEnv), # "width=9, height=6" = assign("window.type", "width=13.5, height=9", envir=.GlobalEnv), # "width=6, height=9" = assign("window.type", "width=9, height=13.5", envir=.GlobalEnv) "width=7, height=7" = justDoIt('window.type <- "width=7, height=7"'), "width=9, height=6" = justDoIt('window.type <- "width=9, height=6"'), "width=6, height=9" = justDoIt('window.type <- "width=6, height=9"') ) } if (size=="Large"){ switch(type, # "width=7, height=7" = window.type <<- "width=10.5, height=10.5", # "width=9, height=6" = window.type <<- "width=13.5, height=9", # "width=6, height=9" = window.type <<- "width=9, height=13.5" # "width=7, height=7" = assign("window.type", "width=10.5, height=10.5", envir=.GlobalEnv), # "width=9, height=6" = assign("window.type", "width=13.5, height=9", envir=.GlobalEnv), # "width=6, height=9" = assign("window.type", "width=9, height=13.5", envir=.GlobalEnv) "width=7, height=7" = justDoIt('window.type <- "width=10.5, height=10.5"'), "width=9, height=6" = justDoIt('window.type <- "width=13.5, height=9"'), "width=6, height=9" = justDoIt('window.type <- "width=9, height=13.5"') ) } if (size=="Small"){ switch(type, # "width=7, height=7" = window.type <<- "width=5, height=5", # "width=9, height=6" = window.type <<- "width=6, height=4", # "width=6, height=9" = window.type <<- "width=4, height=6" # "width=7, height=7" = assign("window.type", "width=5, height=5", envir=.GlobalEnv), # "width=9, height=6" = assign("window.type", "width=6, height=4", envir=.GlobalEnv), # "width=6, height=9" = assign("window.type", "width=4, height=6", envir=.GlobalEnv) "width=7, height=7" = justDoIt('window.type <- "width=5, height=5"'), "width=9, height=6" = justDoIt('window.type <- "width=6, height=4"'), "width=6, height=9" = justDoIt('window.type <- "width=4, height=6"') ) } window.type <- get("window.type", envir=.GlobalEnv) # doItAndPrint(paste("windows(", window.type, ")", sep="")) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", window.type, ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", window.type, ")", sep=""))} else {doItAndPrint(paste("x11(", window.type, ")", sep=""))} # par.option <<- paste("lwd=", lwd, ", las=", las, ', family="', font, '", cex=', cex, sep="") # assign("par.option", paste("lwd=", lwd, ", las=", las, ', family="', font, '", cex=', cex, sep=""), envir=.GlobalEnv) par.option <- paste("lwd=", lwd, ", las=", las, ', family="', font, '", cex=', cex, ", mgp=c(3.0,1,0)", sep="") justDoIt(paste("par.option <- '", par.option, "'", sep="")) par.option <- get("par.option", envir=.GlobalEnv) par.lwd <- paste("lwd=", lwd, sep="") justDoIt(paste("par.lwd <- '", par.lwd, "'", sep="")) justDoIt(paste("par.cex <- '", cex, "'", sep="")) doItAndPrint(paste("par(", par.option, ")", sep="")) doItAndPrint('plot(sin, xlim=c(0,10), main="Sample")') tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="par", apply="StatMedGraphOptions", reset="StatMedGraphOptions") tkgrid(window.sizeFrame, labelRcmdr(optionsFrame, text=" "), window.typeFrame, labelRcmdr(optionsFrame, text=" "), lwdFrame, labelRcmdr(optionsFrame, text=" "), lasFrame, labelRcmdr(optionsFrame, text=" "), familyFrame, labelRcmdr(optionsFrame, text=" "), cexFrame, sticky="w") tkgrid(optionsFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedChangePalette <- function(){ defaults <- list(palette="Standard") dialog.values <- getDialog("StatMedChangePalette", defaults) initializeDialog(title=gettextRcmdr("Graph colors")) optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="palette", buttons=c("Standard", "Gray4", "Gray8", "Heat", "Cold"), values=c("Standard", "Gray4", "Gray8", "Heat", "Cold"), initialValue=dialog.values$palette, labels=gettextRcmdr(c("Standard color", "Gray (4 levels)", "Gray (8 levels)", "Heat", "Cold")), title=gettextRcmdr("Colors")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Graph colors"), "#####", sep="")) palette.type <- tclvalue(paletteVariable) putDialog("StatMedChangePalette", list(palette=palette.type)) closeDialog() switch (palette.type, "Standard"=doItAndPrint('palette("default")'), "Gray4"=doItAndPrint("palette(gray(rep(c(0, 0.3, 0.6, 0.9),2)))"), "Gray8"=doItAndPrint("palette(gray(seq(0, 1, length=8)))"), "Heat"=doItAndPrint("palette(heat.colors(8))"), "Cold"=doItAndPrint("palette(cm.colors(8))") ) if(getRversion() < '3.0.0') { # doItAndPrint(paste("windows(", window.type, "); par(", par.option, ")", sep="")) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} } doItAndPrint('plot(0,1, type="n", yaxt="n", ylab="", xlim=c(0,9), ylim=c(0,1), xlab="Color number")') doItAndPrint("for (i in 1:8) {rect(i-0.5, 0.05, i+0.5, 0.95, col = i)}") doItAndPrint("axis(1, at=1:8)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="palette", apply="StatMedChangePalette", reset="StatMedChangePalette") tkgrid(paletteFrame, labelRcmdr(optionsFrame, text=" "), sticky="w") tkgrid(optionsFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSetPalette <- function() { cval <- function(x,y) -sum((x-y)^2) contrasting <- function(x) optim(rep(127, 3),cval,lower=0,upper=255,method="L-BFGS-B",y=x)$par # the following local function from Thomas Lumley via r-help convert <- function (color){ rgb <- col2rgb(color)/255 L <- c(0.2, 0.6, 0) %*% rgb ifelse(L >= 0.2, "#000060", "#FFFFA0") } env <- environment() pal <- palette() pickColor <- function(initialcolor, parent){ tclvalue(.Tcl(paste("tk_chooseColor", .Tcl.args(title = "Select a Color", initialcolor=initialcolor, parent=parent)))) } Library("tcltk") initializeDialog(title=gettextRcmdr("Graph detailed colors")) hexcolor <- colorConverter(toXYZ = function(hex,...) { rgb <- t(col2rgb(hex))/255 colorspaces$sRGB$toXYZ(rgb,...) }, fromXYZ = function(xyz,...) { rgb <- colorspaces$sRGB$fromXYZ(xyz,..) rgb <- round(rgb,5) if (min(rgb) < 0 || max(rgb) > 1) as.character(NA) else rgb(rgb[1],rgb[2],rgb[3])}, white = "D65", name = "#rrggbb") cols <- t(col2rgb(pal)) hex <- convertColor(cols, from="sRGB", to=hexcolor, scale.in=255, scale.out=NULL) for (i in 1:8) assign(paste("hex", i, sep="."), hex[i], envir=env) paletteFrame <- tkframe(top) button1 <- tkbutton(paletteFrame, text=hex[1], bg = hex[1], fg=convert(hex[1]), command=function() { color <- pickColor(hex[1], parent=button1) fg <- convert(color) tkconfigure(button1, bg=color, fg=fg) assign("hex.1", color, envir=env) } ) button2 <- tkbutton(paletteFrame, text=hex[2], bg = hex[2], fg=convert(hex[2]), command=function() { color <- pickColor(hex[2], parent=button2) fg <- convert(color) tkconfigure(button2, bg=color, fg=fg) assign("hex.2", color, envir=env) } ) button3 <- tkbutton(paletteFrame, text=hex[3], bg = hex[3], fg=convert(hex[3]), command=function() { color <- pickColor(hex[3], parent=button3) fg <- convert(color) tkconfigure(button3, bg=color, fg=fg) assign("hex.3", color, envir=env) } ) button4 <- tkbutton(paletteFrame, text=hex[4], bg = hex[4], fg=convert(hex[4]), command=function() { color <- pickColor(hex[4], parent=button4) fg <- convert(color) tkconfigure(button4, bg=color, fg=fg) assign("hex.4", color, envir=env) } ) button5 <- tkbutton(paletteFrame, text=hex[5], bg = hex[5], fg=convert(hex[5]), command=function() { color <- pickColor(hex[5], parent=button5) fg <- convert(color) tkconfigure(button5, bg=color, fg=fg) assign("hex.5", color, envir=env) } ) button6 <- tkbutton(paletteFrame, text=hex[6], bg = hex[6], fg=convert(hex[6]), command=function() { color <- pickColor(hex[6], parent=button6) fg <- convert(color) tkconfigure(button6, bg=color, fg=fg) assign("hex.6", color, envir=env) } ) button7 <- tkbutton(paletteFrame, text=hex[7], bg = hex[7], fg=convert(hex[7]), command=function() { color <- pickColor(hex[7], parent=button7) fg <- convert(color) tkconfigure(button7, bg=color, fg=fg) assign("hex.7", color, envir=env) } ) button8 <- tkbutton(paletteFrame, text=hex[8], bg = hex[8], fg=convert(hex[8]), command=function() { color <- pickColor(hex[8], parent=button8) fg <- convert(color) tkconfigure(button8, bg=color, fg=fg) assign("hex.8", color, envir=env) } ) onOK <- function(){ logger(paste("#####", gettextRcmdr("Graph detailed colors"), "#####", sep="")) closeDialog(top) if(getRversion() < '3.0.0') { # doItAndPrint(paste("windows(", window.type, "); par(", par.option, ")", sep="")) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} } palette(c(hex.1, hex.2, hex.3, hex.4, hex.5, hex.6, hex.7, hex.8)) logger(paste('palette(c("', hex.1, '", "', hex.2, '", "', hex.3, '", "', hex.4, '", "', hex.5, '", "', hex.6, '", "', hex.7, '", "', hex.8, '"))', sep="")) doItAndPrint('plot(0,1, type="n", yaxt="n", ylab="", xlim=c(0,9), ylim=c(0,1), xlab="Color number")') doItAndPrint("for (i in 1:8) {rect(i-0.5, 0.05, i+0.5, 0.95, col = i)}") doItAndPrint("axis(1, at=1:8)") Message(gettextRcmdr("Color palette reset.", type="note")) } OKCancelHelp(helpSubject="palette") tkgrid(button1, button2, button3, button4, button5, button6, button7, button8) tkgrid(paletteFrame) tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2) } StatMedNumericalSummaries <- function(){ Library("tcltk") initializeDialog(title=gettextRcmdr("Numerical Summaries")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)"), listHeight=15) checkBoxes(frame="checkBoxFrame", boxes=c("graph", "mean", "var", "sd"), initialValues=c("0", "1", "0", "1"), labels=gettextRcmdr(c("Show graph", "Mean", "Variance", "Standard Deviation"))) radioButtons(name="estimation", buttons=c("Corrected", "Uncorrected"), values=c("Corrected", "Uncorrected"), initialValue="Corrected", labels=gettextRcmdr(c("Corrected", "Uncorrected")), title=gettextRcmdr("Calculation of variance and SD")) quantilesVariable <- tclVar("1") quantilesFrame <- tkframe(top) quantilesCheckBox <- tkcheckbutton(quantilesFrame, variable=quantilesVariable) quantiles <- tclVar("0, .25, .5, .75, 1") quantilesEntry <- ttkentry(quantilesFrame, width="20", textvariable=quantiles) StatMedGroupsBox(recall=StatMedNumericalSummaries, label=gettextRcmdr("Summarize by:"), initialLabel=gettextRcmdr("Summarize by groups")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Numerical summaries"), "#####", sep="")) x <- getSelection(xBox) if (length(x) == 0){ errorCondition(recall=StatMedNumericalSummaries, message=gettextRcmdr("You must select a variable.")) return() } graph <- tclvalue(graphVariable) estimation <- tclvalue(estimationVariable) closeDialog() quants <- paste("c(", gsub(",+", ",", gsub(" ", ",", tclvalue(quantiles))), ")", sep="") .activeDataSet <- ActiveDataSet() vars <- if (length(x) == 1) paste('"', x, '"', sep="") else paste("c(", paste('"', x, '"', collapse=", ", sep=""), ")", sep="") vars <- paste(.activeDataSet, "[,", vars, "]", sep="") if(estimation=="Corrected"){ stats <- paste("c(", paste(c('"mean"', '"u.sd"', '"u.var"', '"quantiles"') [c(tclvalue(meanVariable), tclvalue(sdVariable), tclvalue(varVariable), tclvalue(quantilesVariable)) == 1], collapse=", "), ")", sep="") } else { stats <- paste("c(", paste(c('"mean"', '"p.sd"', '"p.var"', '"quantiles"') [c(tclvalue(meanVariable), tclvalue(sdVariable), tclvalue(varVariable), tclvalue(quantilesVariable)) == 1], collapse=", "), ")", sep="") } if (stats == "c()"){ errorCondition(recall=StatMedNumericalSummaries, message=gettextRcmdr("No statistics selected.")) return() } command <- if (.groups != FALSE) { grps <- paste(.activeDataSet, "$", .groups, sep="") doItAndPrint("res <- NULL") paste("res <- numSummary2(", vars, ", groups=", grps, ", statistics=", stats, ", quantiles=", quants, ")", sep="") } else paste("res <- numSummary2(", vars, ", statistics=", stats, ", quantiles=", quants, ")", sep="") doItAndPrint(command) doItAndPrint('colnames(res$table) <- gettextRcmdr( colnames(res$table))') if (graph==1){ for (i in 1:length(x)){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (.groups == FALSE){ doItAndPrint(paste("dummyX <- rep(0, length(", .activeDataSet, "$", x[i], "))")) doItAndPrint(paste("dot.plot(dummyX, ", .activeDataSet, "$", x[i], ', xlab="", ylab="', x[i], '")', sep="")) } else { groupNames <- paste(.activeDataSet, "$", .groups, collapse="*") doItAndPrint(paste("dot.plot(", .activeDataSet, "$", .groups, ", ", .activeDataSet, "$", x[i], ', xlab="', .groups, '", ylab="', x[i], '")', sep="")) } } } doItAndPrint("res") # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="numSummary") tkgrid(labelRcmdr(top, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(xBox), sticky="nw") tkgrid(checkBoxFrame, sticky="w") tkgrid(estimationFrame, sticky="w") tkgrid(labelRcmdr(quantilesFrame, text=gettextRcmdr("Quantiles")), quantilesCheckBox, labelRcmdr(quantilesFrame, text=gettextRcmdr(" quantiles:")), quantilesEntry, sticky="w") tkgrid(quantilesFrame, sticky="w") tkgrid(groupsFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedQQPlot <- function () { # this function modified by Martin Maechler requireNamespace("car") defaults <- list(initial.x = NULL, initial.identify = 0, initial.dist = "norm", initial.df = "", initial.chisqdf = "", initial.fdf1 = "", initial.fdf2 = "", initial.othername = "", initial.otherparam = "") dialog.values <- getDialog("StatMedQQPlot", defaults) initializeDialog(title = gettextRcmdr("Quantile-Comparison (QQ) Plot")) xBox <- variableListBox(top, Numeric(), title = gettextRcmdr("Variable (pick one)"), listHeight=15, initialSelection = varPosn (dialog.values$initial.x, "numeric")) onOK <- function() { logger(paste("#####", gettextRcmdr("Quantile-comparison plot"), "#####", sep="")) x <- getSelection(xBox) initial.dist <-dist <- tclvalue(distVariable) identify <- tclvalue(identifyVariable) tdf <- tclvalue(tDfVariable) chisqdf <- tclvalue(chisqDfVariable) fdf1 <- tclvalue(FDf1Variable) fdf2 <- tclvalue(FDf2Variable) othername <- tclvalue(otherNameVariable) otherparam <- tclvalue(otherParamsVariable) putDialog ("StatMedQQPlot", list (initial.x = x, initial.dist = initial.dist, initial.identify = identify, initial.df = tdf, initial.chisqdf = chisqdf, initial.fdf1 = fdf1, initial.fdf2 = fdf2, initial.othername = othername, initial.otherparam = otherparam)) closeDialog() if (0 == length(x)) { errorCondition(recall = StatMedQQPlot, message = gettextRcmdr("You must select a variable.")) return() } save <- options(warn = -1) on.exit(save) retryMe <- function(msg) { Message(message = msg, type = "error") QQPlot() } switch(dist, norm = { args <- "dist=\"norm\"" }, t = { df <- tclvalue(tDfVariable) df.num <- as.numeric(df) if (is.na(df.num) || df.num < 1) { retryMe(gettextRcmdr("df for t must be a positive number.")) return() } args <- paste("dist=\"t\", df=", df, sep = "") }, chisq = { df <- tclvalue(chisqDfVariable) df.num <- as.numeric(df) if (is.na(df.num) || df.num < 1) { retryMe(gettextRcmdr("df for chi-square must be a positive number.")) return() } args <- paste("dist=\"chisq\", df=", df, sep = "") }, f = { df1 <- tclvalue(FDf1Variable) df2 <- tclvalue(FDf2Variable) df.num1 <- as.numeric(df1) df.num2 <- as.numeric(df2) if (is.na(df.num1) || df.num1 < 1 || is.na(df.num2) || df.num2 < 1) { retryMe(gettextRcmdr("numerator and denominator \ndf for F must be positive numbers.")) return() } args <- paste("dist=\"f\", df1=", df1, ", df2=", df2, sep = "") }, { dist <- tclvalue(otherNameVariable) params <- tclvalue(otherParamsVariable) args <- paste("dist=\"", dist, "\", ", params, sep = "") }) .activeDataSet <- ActiveDataSet() if ("1" == tclvalue(identifyVariable)) { RcmdrTkmessageBox(title = "Identify Points", message = paste(gettextRcmdr("Use left mouse button to identify points,\n"), gettextRcmdr(if (MacOSXP()) "esc key to exit." else "right button to exit."), sep = ""), icon = "info", type = "ok") idtext <- paste(", labels=rownames(", .activeDataSet, "), id.method=\"identify\"", sep = "") } else idtext <- "" if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("qqPlot", "(", .activeDataSet, "$", x, ", ", args, idtext, ")", sep = "") doItAndPrint(command) activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject = "qqPlot", apply="StatMedQQPlot", reset = "StatMedQQPlot") distFrame <- tkframe(top) distVariable <- tclVar(dialog.values$initial.dist) normalButton <- ttkradiobutton(distFrame, variable = distVariable, value = "norm") tButton <- ttkradiobutton(distFrame, variable = distVariable, value = "t") chisqButton <- ttkradiobutton(distFrame, variable = distVariable, value = "chisq") FButton <- ttkradiobutton(distFrame, variable = distVariable, value = "f") otherButton <- ttkradiobutton(distFrame, variable = distVariable, value = "other") tDfFrame <- tkframe(distFrame) tDfVariable <- tclVar(dialog.values$initial.df) tDfField <- ttkentry(tDfFrame, width = "6", textvariable = tDfVariable) chisqDfFrame <- tkframe(distFrame) chisqDfVariable <- tclVar(dialog.values$initial.chisqdf) chisqDfField <- ttkentry(chisqDfFrame, width = "6", textvariable = chisqDfVariable) FDfFrame <- tkframe(distFrame) FDf1Variable <- tclVar(dialog.values$initial.fdf1) FDf1Field <- ttkentry(FDfFrame, width = "6", textvariable = FDf1Variable) FDf2Variable <- tclVar(dialog.values$initial.fdf2) FDf2Field <- ttkentry(FDfFrame, width = "6", textvariable = FDf2Variable) otherParamsFrame <- tkframe(distFrame) otherParamsVariable <- tclVar(dialog.values$initial.otherparam) otherParamsField <- ttkentry(otherParamsFrame, width = "30", textvariable = otherParamsVariable) otherNameVariable <- tclVar(dialog.values$initial.othername) otherNameField <- ttkentry(otherParamsFrame, width = "10", textvariable = otherNameVariable) identifyVariable <- tclVar(dialog.values$initial.identify) identifyFrame <- tkframe(top) identifyCheckBox <- tkcheckbutton(identifyFrame, variable = identifyVariable) tkgrid(getFrame(xBox), sticky = "nw") tkgrid(labelRcmdr(identifyFrame, text = gettextRcmdr("Identify observations with mouse")), identifyCheckBox, sticky = "w") tkgrid(identifyFrame, sticky = "w") tkgrid(labelRcmdr(distFrame, text = gettextRcmdr("Distribution"), fg = "blue"), columnspan = 6, sticky = "w") tkgrid(labelRcmdr(distFrame, text = gettextRcmdr("Normal")), normalButton, sticky = "w") tkgrid(labelRcmdr(tDfFrame, text = gettextRcmdr("df = ")), tDfField, sticky = "w") tkgrid(labelRcmdr(distFrame, text = "t"), tButton, tDfFrame, sticky = "w") tkgrid(labelRcmdr(chisqDfFrame, text = gettextRcmdr("df = ")), chisqDfField, sticky = "w") tkgrid(labelRcmdr(distFrame, text = gettextRcmdr("Chi-square")), chisqButton, chisqDfFrame, sticky = "w") tkgrid(labelRcmdr(FDfFrame, text = gettextRcmdr("Numerator df = ")), FDf1Field, labelRcmdr(FDfFrame, text = gettextRcmdr("Denominator df = ")), FDf2Field, sticky = "w") tkgrid(labelRcmdr(distFrame, text = "F"), FButton, FDfFrame, sticky = "w") tkgrid(labelRcmdr(otherParamsFrame, text = gettextRcmdr("Specify: ")), otherNameField, labelRcmdr(otherParamsFrame, text = gettextRcmdr("Parameters: ")), otherParamsField, sticky = "w") tkgrid(labelRcmdr(distFrame, text = gettextRcmdr("Other")), otherButton, otherParamsFrame, sticky = "w") tkgrid(distFrame, sticky = "w") tkgrid(buttonsFrame, sticky = "w") dialogSuffix(rows = 5, columns = 1) } StatMedHistogram <- function(){ defaults <- list(x=NULL, group=NULL, color=0, bins="<auto>", scale="frequency", subset="") dialog.values <- getDialog("StatMedHistogram", defaults) currentFields$subset <- dialog.values$subset #Valued of currentFields will be sent to subsetBox currentModel <- TRUE initializeDialog(title=gettextRcmdr("Histogram")) variablesFrame <- tkframe(top) xBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$x, "numeric")) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) checkBoxes(frame="color", boxes=c("color"),initialValues=dialog.values$color,labels=gettextRcmdr(c("Draw in color (when grouped)"))) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Histogram"), "#####", sep="")) x <- getSelection(xBox) group <- getSelection(groupBox) color <- tclvalue(colorVariable) bins <- tclvalue(binsVariable) scale <- tclvalue(scaleVariable) subset <- tclvalue(subsetVariable) putDialog("StatMedHistogram", list(x=x, group=group, color=color, bins=tclvalue(binsVariable), scale=scale, subset=tclvalue(subsetVariable))) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } closeDialog() if (length(x) == 0){ errorCondition(recall=StatMedHistogram, message=gettextRcmdr("You must select a variable")) return() } opts <- options(warn=-1) # bins <- if (bins == gettextRcmdr("<auto>")) '"Sturges"' else as.numeric(bins) bins <- if (bins == gettextRcmdr("<auto>")) '"scott"' else as.numeric(bins)-1 #chabge default to Scott, bins <- bins - 1 options(opts) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (length(group)==0) { command <- paste("HistEZR(", subset1, ActiveDataSet(), subset2, "$", x, ', scale="', scale, '", breaks=', bins, ', xlab="', x, '", col="darkgray")', sep="") doItAndPrint(command) } else { groups <- eval(parse(text=paste("levels(factor(", subset1, ActiveDataSet(), subset2, "$", group, "))", sep=""))) ngroup <- length(groups) if (color == 0){ color <- NULL } else { color <- paste(", col=c(2:", ngroup+1, ")", sep="") } doItAndPrint(paste("res <- hist(", subset1, ActiveDataSet(), subset2, "$", x, ", breaks='scott', plot=FALSE)", sep="")) command <- paste("temp.y <- ", subset1, ActiveDataSet(), subset2, "[", subset1, ActiveDataSet(), subset2, "$", group, '=="', groups[1], '",]$', x, sep="") doItAndPrint(command) doItAndPrint("temp.h <- hist(temp.y, breaks=res$breaks, plot=FALSE)$counts") if (ngroup >=2){ for (i in 2:ngroup){ command <- paste("temp.y <- ", subset1, ActiveDataSet(), subset2, "[", subset1, ActiveDataSet(), subset2, "$", group, '=="', groups[i], '",]$', x, sep="") doItAndPrint(command) doItAndPrint("temp.h <- rbind(temp.h, hist(temp.y, breaks=res$breaks, plot=FALSE)$counts)") } command <- paste("barplot(temp.h, beside=TRUE, space=c(0, 0.4), names.arg=res$breaks[-length(temp.h[1])], legend=levels(factor(", ActiveDataSet(), "$", group, ')), args.legend=list(title="', group, '", box.lty=0), axis.lty=1, axisnames=TRUE', color, ")", sep="") doItAndPrint(command) doItAndPrint("breaks <- NULL") doItAndPrint('for (i in 1:(length(res$breaks)-1)){breaks[i] <- paste(res$breaks[i], "-", res$breaks[i+1], sep="")}') doItAndPrint("colnames(temp.h) <- breaks") doItAndPrint(paste("rownames(temp.h) <- levels(as.factor(", subset1, ActiveDataSet(), subset2, "$", group, "))", sep="")) doItAndPrint("temp.h") } } activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Hist", apply="StatMedHistogram", reset="StatMedHistogram") radioButtons(name="scale", buttons=c("frequency", "percent", "density"), initialValue=dialog.values$scale, labels=gettextRcmdr(c("Frequency counts", "Percentages", "Densities")), title=gettextRcmdr("Y axis (when not grouped)")) binsFrame <- tkframe(top) binsVariable <- tclVar(gettextRcmdr(dialog.values$bins)) binsField <- ttkentry(binsFrame, width="6", textvariable=binsVariable) tkgrid(getFrame(xBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(color, sticky="w") tkgrid(labelRcmdr(binsFrame, text=gettextRcmdr("Number of sections (when not grouped)")), binsField, sticky="w") tkgrid(binsFrame, sticky="w") tkgrid(scaleFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") tkgrid.configure(binsField, sticky="e") dialogSuffix(rows=4, columns=1) } StatMedStemAndLeaf <- function(){ defaults <- list(initial.x = NULL, initial.leafs.auto="1", initial.unit = 0, initial.m = "auto", initial.trim = 1, initial.depths = 1, initial.reverse = 1, initial.style = "Tukey") dialog.values <- getDialog("StatMedStemAndLeaf", defaults) initializeDialog(title=gettextRcmdr("Stem and Leaf Display"), preventCrisp=TRUE) xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"), listHeight=10, initialSelection = varPosn (dialog.values$initial.x, "numeric")) displayDigits <- tclVar("1") onDigits <- function(...){ tclvalue(displayDigits) <- formatC(10^as.numeric(tclvalue(leafsDigitValue)), format="fg", big.mark=",") tclvalue(leafsAutoVariable) <- "0" } radioButtons(name = "parts", buttons = c("auto", "one", "two", "five"), values = c("auto", "1", "2", "5"), labels = c(gettextRcmdr("Automatic"), " 1", " 2", " 5"), title = gettextRcmdr("Parts Per Stem"), initialValue = dialog.values$initial.m) radioButtons(name = "style", buttons = c("Tukey", "bare"), labels = gettextRcmdr(c("Tukey", "Repeated stem digits")), title = gettextRcmdr("Style of Divided Stems"), initialValue = dialog.values$initial.style) checkBoxes(frame = "optionsFrame", boxes = c("trimOutliers", "showDepths", "reverseNegative"), initialValues = c(dialog.values$initial.trim, dialog.values$initial.depths, dialog.values$initial.reverse), labels = gettextRcmdr(c("Trim outliers", "Show depths", "Reverse negative leaves"))) # radioButtons(name="parts", buttons=c("auto", "one", "two", "five"), # values=c("auto", "1", "2", "5"), labels=c(gettextRcmdr("Automatic"), " 1", " 2", " 5"), # title=gettextRcmdr("Parts Per Stem")) # radioButtons(name="style", buttons=c("Tukey", "bare"), labels=gettextRcmdr(c("Tukey", "Repeated stem digits")), # title=gettextRcmdr("Style of Divided Stems")) # checkBoxes(frame="optionsFrame", boxes=c("trimOutliers", "showDepths", "reverseNegative"), # initialValues=rep(1, 3), labels=gettextRcmdr(c("Trim outliers", "Show depths", "Reverse negative leaves"))) leafsFrame <- tkframe(top) leafsDigitValue <- tclVar(dialog.values$initial.unit) #tclVar("0") leafsDigitSlider <- tkscale(leafsFrame, from = -6, to = 6, showvalue = FALSE, variable = leafsDigitValue, resolution = 1, orient = "horizontal", command = onDigits) leafsDigitShow <- labelRcmdr(leafsFrame, textvariable = displayDigits, width = 8, justify = "right") leafsAutoVariable <- tclVar("1") # tclVar(dialog.values$initial.leafs.auto) leafsDigitCheckBox <- tkcheckbutton(leafsFrame, variable = leafsAutoVariable) # leafsFrame <- tkframe(top) # leafsDigitValue <- tclVar("0") # leafsDigitSlider <- tkscale(leafsFrame, from=-6, to=6, showvalue=FALSE, variable=leafsDigitValue, # resolution=1, orient="horizontal", command=onDigits) # leafsDigitShow <- labelRcmdr(leafsFrame, textvariable=displayDigits, width=8, justify="right") # leafsAutoVariable <- tclVar("1") # leafsDigitCheckBox <- tkcheckbutton(leafsFrame, variable=leafsAutoVariable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Stem and Leaf Display"), "#####", sep="")) x <- getSelection(xBox) m <- tclvalue(partsVariable) style <- tclvalue (styleVariable) trim <- tclvalue (trimOutliersVariable) depths <- tclvalue (showDepthsVariable) reverse <- tclvalue (reverseNegativeVariable) unit <- if (tclvalue(leafsAutoVariable) == "1") "" else paste(", unit=", 10^as.numeric(tclvalue(leafsDigitValue)), sep = "") putDialog ("StatMedStemAndLeaf", list(initial.x = x, initial.leafs.auto=tclvalue(leafsAutoVariable), initial.unit = as.numeric(tclvalue(leafsDigitValue)), initial.m = m, initial.trim = trim, initial.depths = depths, initial.reverse = reverse, initial.style = style)) closeDialog() if (length(x) == 0) { errorCondition(recall = StatMedStemAndLeaf, message = gettextRcmdr("You must select a variable")) return() } trim <- if (tclvalue(trimOutliersVariable) == "1") "" else ", trim.outliers=FALSE" depths <- if (tclvalue(showDepthsVariable) == "1") "" else ", depths=FALSE" reverse <- if (tclvalue(reverseNegativeVariable) == "1") "" else ", reverse.negative.leaves=FALSE" m <- if (tclvalue(partsVariable) == "auto") "" else paste(", m=", tclvalue(partsVariable), sep = "") style <- if (tclvalue(styleVariable) == "Tukey") "" else ", style=\"bare\"" doItAndPrint("library(aplpack)") command <- paste("stem.leaf(", ActiveDataSet(), "$", x, style, unit, m, trim, depths, reverse, ", na.rm=TRUE)", sep = "") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject = "stem.leaf", apply = "StatMedStemAndLeaf", reset = "StatMedStemAndLeaf") tkgrid(getFrame(xBox), sticky = "nw") tkgrid(labelRcmdr(leafsFrame, text = gettextRcmdr("Leafs Digit: "), fg = "blue"), labelRcmdr(leafsFrame, text = gettextRcmdr("Automatic")), leafsDigitCheckBox, labelRcmdr(leafsFrame, text = gettextRcmdr(" or set:"), fg = "red"), leafsDigitShow, leafsDigitSlider, sticky = "w") # tkgrid(labelRcmdr(leafsFrame, text=gettextRcmdr("Leafs Digit: "), fg="blue"), # labelRcmdr(leafsFrame, text=gettextRcmdr("Automatic")), leafsDigitCheckBox, # labelRcmdr(leafsFrame, text=gettextRcmdr(" or set:"), fg="red"), leafsDigitShow, leafsDigitSlider, sticky="w") tkgrid(leafsFrame, sticky = "w") tkgrid(partsFrame, sticky = "w") tkgrid(styleFrame, sticky = "w") tkgrid(labelRcmdr(top, text = gettextRcmdr("Options"), fg = "blue"), sticky = "w") # tkgrid(labelRcmdr(top, text=gettextRcmdr("Options"), fg="blue"), sticky="w") tkgrid(optionsFrame, sticky = "w") tkgrid(buttonsFrame, sticky = "w") tclvalue(leafsAutoVariable) <- dialog.values$initial.leafs.auto # tclvalue(leafsAutoVariable) <- "1" dialogSuffix(rows = 7, columns = 1, preventCrisp = TRUE) } StatMedBoxPlot <- function(){ defaults <- list(x=NULL, group=NULL, logy=0, whisker="90", subset = "") dialog.values <- getDialog("StatMedBoxPlot", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Boxplot")) variablesFrame <- tkframe(top) xBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$x, "numeric")) checkBoxes(frame="logy", boxes=c("logy"),initialValues=dialog.values$logy,labels=gettextRcmdr(c("Log y-axis"))) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) # identifyVariable <- tclVar("0") # identifyFrame <- tkframe(top) # identifyCheckBox <- tkcheckbutton(identifyFrame, variable=identifyVariable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Boxplot"), "#####", sep="")) x <- getSelection(xBox) group <- getSelection(groupBox) logy <- tclvalue(logyVariable) whisker <- tclvalue(whiskerVariable) subset <- tclvalue(subsetVariable) putDialog("StatMedBoxPlot", list(x=x, group=group, logy=logy, whisker=whisker, subset = tclvalue(subsetVariable))) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } closeDialog() if (length(x) == 0){ errorCondition(recall=StatMedBoxPlot, message=gettextRcmdr("You must select a variable")) return() } if (logy==0){ logy <- "" } else{ logy <- ', log="y"' } # identifyPoints <- "1" == tclvalue(identifyVariable) .activeDataSet <- ActiveDataSet() # var <- paste(subset1, .activeDataSet, subset2, "[complete.cases(", subset1, .activeDataSet, subset2, "$", x, "),]$", x, sep="") var <- paste(subset1, .activeDataSet, subset2, "$", x, "[complete.cases(", subset1, .activeDataSet, subset2, "$", x, ")]", sep="") compgroup <- paste(subset1, .activeDataSet, subset2, "[complete.cases(", subset1, .activeDataSet, subset2, "$", x, "),]$", group, sep="") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (length(group) == 0) { if(whisker=="default"){ command <- (paste("boxplot(", var, ', ylab="', x, '"', logy, ')', sep="")) doItAndPrint(command) } else { command <- (paste("boxdata <- boxplot(", var, ', ylab="', x, '"', logy, ', plot=FALSE)', sep="")) doItAndPrint(command) if(whisker=="90"){ doItAndPrint(paste("boxdata$stats[1,] <- quantile(", var, ", .1, na.rm=TRUE)", sep="")) doItAndPrint(paste("boxdata$stats[5,] <- quantile(", var, ", .9, na.rm=TRUE)", sep="")) doItAndPrint(paste("boxdata.outliers <- ", var, "[", var , "<boxdata$stats[1,] | ", var, ">boxdata$stats[5,]]", sep="")) doItAndPrint("boxdata$out <- c(boxdata$out, boxdata.outliers)") doItAndPrint(paste("boxdata$group <- c(boxdata$group, rep(1, length(boxdata.outliers)))", sep="")) } if(whisker=="95"){ doItAndPrint(paste("boxdata$stats[1,] <- quantile(", var, ", .05, na.rm=TRUE)", sep="")) doItAndPrint(paste("boxdata$stats[5,] <- quantile(", var, ", .95, na.rm=TRUE)", sep="")) doItAndPrint(paste("boxdata.outliers <- ", var, "[", var , "<boxdata$stats[1,] | ", var, ">boxdata$stats[5,]]", sep="")) doItAndPrint("boxdata$out <- c(boxdata$out, boxdata.outliers)") doItAndPrint(paste("boxdata$group <- c(boxdata$group, rep(1, length(boxdata.outliers)))", sep="")) } if(whisker=="maxmin"){ doItAndPrint(paste("boxdata$stats[1,] <- min(", var, ", na.rm=TRUE)", sep="")) doItAndPrint(paste("boxdata$stats[5,] <- max(", var, ", na.rm=TRUE)", sep="")) doItAndPrint("boxdata$out <- NULL") doItAndPrint("boxdata$group <- NULL") } doItAndPrint(paste('bxp(boxdata, ylab="', x, '"', logy, ")", sep="")) doItAndPrint("remove(boxdata)") doItAndPrint("remove(boxdata.outliers)") } } else { if(whisker=="default"){ command <- (paste("boxplot(", x, "~ factor(", group, '), ylab="', x, '", xlab="', group,'"', ", data=", .activeDataSet, subset, logy, ")", sep="")) doItAndPrint(command) } else { command <- (paste("boxdata <- boxplot(", x, "~ factor(", group, '), ylab="', x, '", xlab="', group,'"', ", data=", .activeDataSet, subset, logy, ", plot=FALSE)", sep="")) doItAndPrint(command) groups <- eval(parse(text=paste("levels(factor(", subset1, .activeDataSet, subset2, "$", group, "))", sep=""))) ngroup <- length(groups) doItAndPrint("boxdata$out <- NULL") doItAndPrint("boxdata$group <- NULL") for (i in 1:ngroup){ if(whisker=="90"){ doItAndPrint(paste("boxdata$stats[1,", i, "] <- quantile(", var, "[", compgroup, '=="', groups[i], '"], .1, na.rm=TRUE)', sep="")) doItAndPrint(paste("boxdata$stats[5,", i, "] <- quantile(", var, "[", compgroup, '=="', groups[i], '"], .9, na.rm=TRUE)', sep="")) doItAndPrint(paste("boxdata.outliers <- ", subset1, .activeDataSet, subset2, "[!is.na(", subset1, .activeDataSet, subset2, "$", x, ") & ", subset1, .activeDataSet, subset2, "$", group, '=="', groups[i], '",]$', x, "[", subset1, .activeDataSet, subset2, "[!is.na(", subset1, .activeDataSet, subset2, "$", x, ") & ", subset1, .activeDataSet, subset2, "$", group, '=="', groups[i], '",]$', x , "<boxdata$stats[1,", i, "] | ", subset1, .activeDataSet, subset2, "[!is.na(", subset1, .activeDataSet, subset2, "$", x, ") & ", subset1, .activeDataSet, subset2, "$", group, '=="', groups[i], '",]$', x , ">boxdata$stats[5,", i, "]]", sep="")) doItAndPrint("boxdata$out <- c(boxdata$out, boxdata.outliers)") doItAndPrint(paste("boxdata$group <- c(boxdata$group, rep(", i, ", length(boxdata.outliers)))", sep="")) } if(whisker=="95"){ doItAndPrint(paste("boxdata$stats[1,", i, "] <- quantile(", var, "[", compgroup, '=="', groups[i], '"], .05, na.rm=TRUE)', sep="")) doItAndPrint(paste("boxdata$stats[5,", i, "] <- quantile(", var, "[", compgroup, '=="', groups[i], '"], .95, na.rm=TRUE)', sep="")) doItAndPrint(paste("boxdata.outliers <- ", subset1, .activeDataSet, subset2, "[!is.na(", subset1, .activeDataSet, subset2, "$", x, ") & ", subset1, .activeDataSet, subset2, "$", group, '=="', groups[i], '",]$', x, "[", subset1, .activeDataSet, subset2, "[!is.na(", subset1, .activeDataSet, subset2, "$", x, ") & ", subset1, .activeDataSet, subset2, "$", group, '=="', groups[i], '",]$', x , "<boxdata$stats[1,", i, "] | ", subset1, .activeDataSet, subset2, "[!is.na(", subset1, .activeDataSet, subset2, "$", x, ") & ", subset1, .activeDataSet, subset2, "$", group, '=="', groups[i], '",]$', x , ">boxdata$stats[5,", i, "]]", sep="")) doItAndPrint("boxdata$out <- c(boxdata$out, boxdata.outliers)") doItAndPrint(paste("boxdata$group <- c(boxdata$group, rep(", i, ", length(boxdata.outliers)))", sep="")) } if(whisker=="maxmin"){ doItAndPrint(paste("boxdata$stats[1,", i, "] <- min(", var, "[", compgroup, '=="', groups[i], '"], na.rm=TRUE)', sep="")) doItAndPrint(paste("boxdata$stats[5,", i, "] <- max(", var, "[", compgroup, '=="', groups[i], '"], na.rm=TRUE)', sep="")) doItAndPrint("boxdata$out <- NULL") doItAndPrint("boxdata$group <- NULL") } } doItAndPrint(paste('bxp(boxdata, ylab="', x, '"', logy, ")", sep="")) doItAndPrint("remove(boxdata)") doItAndPrint("remove(boxdata.outliers)") } } # if (identifyPoints) { # RcmdrTkmessageBox(title="Identify Points", # message=paste(gettextRcmdr("Use left mouse button to identify points,\n"), # gettextRcmdr(if (MacOSXP()) "esc key to exit." else "right button to exit."), sep=""), # icon="info", type="ok") # doItAndPrint(paste("identify(rep(1, length(", var, # ")), ", var, ", rownames(", .activeDataSet,"))", sep="")) # } activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="boxplot", apply="StatMedBoxPlot", reset="StatMedBoxPlot") tkgrid(getFrame(xBox), labelRcmdr(variablesFrame, text=gettextRcmdr(" ")), getFrame(groupBox), sticky="w") tkgrid(variablesFrame, stick="w") tkgrid(logy, sticky="w") radioButtons(name="whisker", buttons=c("ninety", "ninetyfive", "maxmin", "default"), values=c("90", "95", "maxmin", "default"), initialValue=dialog.values$whisker, labels=gettextRcmdr(c("10-90 percentiles", "5-95 percentiles", "Min-Max", "(1Q-1.5xIQR)-(3Q+1.5xIQR)")), title=gettextRcmdr("Whisker range")) tkgrid(whiskerFrame, sticky="nw") # tkgrid(labelRcmdr(identifyFrame, text=gettextRcmdr("Identify outliers with mouse"), justify="left"), # identifyCheckBox, sticky="w") # tkgrid(identifyFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedBarMeans <- function(){ defaults <- list(group1=NULL, group2=NULL, response=NULL, errorBars="bar.sds", subset="") dialog.values <- getDialog("StatMedBarMeans", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Bar graph(Means)")) variablesFrame <- tkframe(top) group1Box <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable1(pick 0 or 1)"), listHeight=15, initialSelection=varPosn(dialog.values$group1, "all")) group2Box <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable2(pick 0 or 1)"), listHeight=15, initialSelection=varPosn(dialog.values$group2, "all")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Bar graph(Means)"), "#####", sep="")) group1 <- getSelection(group1Box) group2 <- getSelection(group2Box) response <- getSelection(responseBox) error.bars <- tclvalue(errorBarsVariable) subset <- tclvalue(subsetVariable) putDialog("StatMedBarMeans", list(group1=group1, group2=group2, response=response, errorBars=error.bars, subset=tclvalue(subsetVariable))) if (error.bars=="conf.int") error.bars <- "bar.ses*qnorm(0.975)" if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } closeDialog() if (length(response) == 0) { errorCondition(recall=StatMedBarMeans, message=gettextRcmdr("No response variable selected.")) return() } dataSet <- ActiveDataSet() if (length(group1) == 0){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint(paste("bar.sums <- sum(", subset1, dataSet, subset2, "$", response, ", na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.means <- mean(", subset1, dataSet, subset2, "$", response, ", na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.sds <- sd(", subset1, dataSet, subset2, "$", response, ", na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.n <- bar.sums/bar.means")) doItAndPrint(paste("bar.ses <- bar.sds/sqrt(bar.n)")) doItAndPrint("bar.sds <- ifelse(is.na(bar.sds), 0, bar.sds)") doItAndPrint("bar.ses <- ifelse(is.na(bar.ses), 0, bar.ses)") if (error.bars == "none"){ doItAndPrint(paste('barx <- barplot(bar.means, ylim=c(ifelse(min(bar.means)>0, 0, min(bar.means)*1.2), max(bar.means)*1.2), ylab="', response, '", axis.lty=1)',sep="")) } else{ doItAndPrint(paste('barx <- barplot(bar.means, ylim=c(ifelse(min(bar.means)>0, 0, min(bar.means-', error.bars, ')*1.2), max(bar.means+', error.bars, ')*1.2), ylab="', response, '", axis.lty=1)',sep="")) doItAndPrint(paste("error.bar(barx, bar.means, ", error.bars, ")", sep="")) } } if (length(group1) == 1 && length(group2) == 0){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint(paste("bar.sums <- tapply(", subset1, dataSet, subset2, "$", response, ", factor(", subset1, dataSet, subset2, "$", group1, "), sum, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.means <- tapply(", subset1, dataSet, subset2, "$", response, ", factor(", subset1, dataSet, subset2, "$", group1, "), mean, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.sds <- tapply(", subset1, dataSet, subset2, "$", response, ", factor(", subset1, dataSet, subset2, "$", group1, "), sd, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.n <- bar.sums/bar.means")) doItAndPrint(paste("bar.ses <- bar.sds/sqrt(bar.n)")) doItAndPrint("bar.sds <- ifelse(is.na(bar.sds), 0, bar.sds)") doItAndPrint("bar.ses <- ifelse(is.na(bar.ses), 0, bar.ses)") if (error.bars == "none"){ doItAndPrint(paste('barx <- barplot(bar.means, ylim=c(ifelse(min(bar.means, na.rm=TRUE)>0, 0, min(bar.means, na.rm=TRUE)*1.2), max(bar.means, na.rm=TRUE)*1.2), xlab="', group1, '", ylab="', response, '", axis.lty=1)',sep="")) } else{ doItAndPrint(paste('barx <- barplot(bar.means, ylim=c(ifelse(min(bar.means, na.rm=TRUE)>0, 0, min(bar.means-', error.bars, ', na.rm=TRUE)*1.2), max(bar.means+', error.bars, ', na.rm=TRUE)*1.2), xlab="', group1, '", ylab="', response, '", axis.lty=1)',sep="")) doItAndPrint(paste("error.bar(barx, bar.means, ", error.bars, ")", sep="")) } } if (length(group1) == 1 && length(group2) == 1){ if (eval(parse(text=paste("min(table(", subset1, dataSet, subset2, "$", group1, ", ", subset1, dataSet, subset2, "$", group2, "))", sep="")))==0) { logger(gettextRcmdr("Graph not created when a group with 0 sample exists")) } else { eval.bar.var <- eval(parse(text=paste("length(levels(factor(", subset1, dataSet, subset2, "$", group2, ")))", sep=""))) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint(paste("bar.var <- length(levels(factor(", subset1, dataSet, subset2, "$", group2, ")))", sep="")) doItAndPrint(paste("bar.sums <- tapply(subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[1])$", response, ", subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[1])$", group1, ", sum, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.means <- tapply(subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[1])$", response, ", subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[1])$", group1, ", mean, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.sds <- tapply(subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[1])$", response, ", subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[1])$", group1, ", sd, na.rm=TRUE)", sep="")) if(eval.bar.var > 1){ for (i in 2: eval.bar.var){ doItAndPrint(paste("bar.sums <- c(bar.sums, tapply(subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[", i, "])$", response, ", subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[", i, "])$", group1, ", sum, na.rm=TRUE))", sep="")) doItAndPrint(paste("bar.means <- c(bar.means, tapply(subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[", i, "])$", response, ", subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[", i, "])$", group1, ", mean, na.rm=TRUE))", sep="")) doItAndPrint(paste("bar.sds <- c(bar.sds, tapply(subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[", i, "])$", response, ", subset(", subset1, dataSet, subset2, ", ", group2, "==levels(factor(", group2, "))[", i, "])$", group1, ", sd, na.rm=TRUE))", sep="")) doItAndPrint("bar.n <- bar.sums/bar.means") doItAndPrint("bar.ses <- bar.sds/sqrt(bar.n)") } } doItAndPrint(paste("bar.var2 <- length(levels(factor(", subset1, dataSet, subset2, "$", group1, ")))", sep="")) doItAndPrint("bar.means <- matrix(bar.means, bar.var2)") doItAndPrint("bar.sds <- matrix(bar.sds, bar.var2)") doItAndPrint("bar.ses <- matrix(bar.ses, bar.var2)") doItAndPrint("bar.sds <- ifelse(is.na(bar.sds), 0, bar.sds)") doItAndPrint("bar.ses <- ifelse(is.na(bar.ses), 0, bar.ses)") if (error.bars == "none"){ doItAndPrint(paste('barx <- barplot(bar.means, beside=TRUE, ylim=c(ifelse(min(bar.means)>0, 0, min(bar.means)*1.2), max(bar.means)*1.2), xlab="', group2, '", ylab="', response, '", names.arg=levels(factor(', subset1, dataSet, subset2, "$", group2, ")), legend.text=levels(factor(", subset1, dataSet, subset2, "$", group1, ')), args.legend=list(title="', group1, '", box.lty=0), axis.lty=1)', sep="")) } else{ doItAndPrint(paste('barx <- barplot(bar.means, beside=TRUE, ylim=c(ifelse(min(bar.means)>0, 0, min(bar.means-', error.bars, ')*1.2), max(bar.means+', error.bars, ')*1.2), xlab="', group2, '", ylab="', response, '", names.arg=levels(factor(', subset1, dataSet, subset2, "$", group2, ")), legend.text=levels(factor(", subset1, dataSet, subset2, "$", group1, ')), args.legend=list(title="', group1, '", box.lty=0), axis.lty=1)', sep="")) doItAndPrint(paste("error.bar(barx, bar.means, ", error.bars, ")", sep="")) } } } activateMenus() tkfocus(CommanderWindow()) } optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="errorBars", buttons=c("bar.ses", "bar.sds", "conf.int", "none"), values=c("bar.ses", "bar.sds", "conf.int", "none"),initialValue=dialog.values$errorBars, labels=gettextRcmdr(c("Standard errors", "Standard deviations", "Confidence intervals", "No error bars")), title=gettextRcmdr("Error Bars")) # errorBarsVariable <- tclVar("bar.sds") # seButton <- ttkradiobutton(optionsFrame, variable=errorBarsVariable, value="bar.ses") # sdButton <- ttkradiobutton(optionsFrame, variable=errorBarsVariable, value="bar.sds") # noneButton <- ttkradiobutton(optionsFrame, variable=errorBarsVariable, value="none") buttonsFrame <- tkframe(top) OKCancelHelp(helpSubject="barplot", apply="StatMedBarMeans", reset="StatMedBarMeans") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(group1Box), getFrame(group2Box), sticky="nw") tkgrid(variablesFrame, sticky="nw") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Error Bars"), fg="blue"), sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Standard errors")), seButton, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Standard deviations")), sdButton, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("No error bars")), noneButton, sticky="w") tkgrid(errorBarsFrame, columnspan=2, sticky="w") tkgrid(optionsFrame, columnspan=2, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } StatMedStripChart <- function(){ defaults <- list(group=NULL, response=NULL, logy=0, subset = "") dialog.values <- getDialog("StatMedStripChart", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Strip Chart")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) checkBoxes(frame="logy", boxes=c("logy"),initialValues=dialog.values$logy,labels=gettextRcmdr(c("Log y-axis"))) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Strip Chart"), "#####", sep="")) groups <- getSelection(groupBox) response <- getSelection(responseBox) logy <- tclvalue(logyVariable) .activeDataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) putDialog("StatMedStripChart", list(group=groups, response=response, logy=logy, subset = tclvalue(subsetVariable))) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { .subDataSet <- .activeDataSet } else { .subDataSet <- paste("subset(", .activeDataSet, ", ", subset, ")", sep="") } closeDialog() if (0 == length(response)) { errorCondition(recall=StatMedStripChart, message=gettextRcmdr("No response variable selected.")) return() } if (logy==0){ logy <- "" logflag <- "" } else{ logy <- ', log="y"' logflag <- ", log.flag=TRUE" } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (length(groups) == 0){ doItAndPrint(paste("dummyX <- rep(0, length(", .subDataSet, "$", response, "))")) doItAndPrint(paste("dot.plot(dummyX, ", .subDataSet, "$", response, logflag, ', xlab="", ylab="', response, '")', sep="")) } else { doItAndPrint(paste("dot.plot(", .subDataSet, "$", groups, ", ", .subDataSet, "$", response, logflag, ', xlab="', groups, '", ylab="', response, '")', sep="")) } activateMenus() tkfocus(CommanderWindow()) } buttonsFrame <- tkframe(top) OKCancelHelp(helpSubject="plot", apply="StatMedStripChart", reset="StatMedStripChart") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(logy, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } StatMedOrderedChart <- function(){ defaults <- list(response=NULL, group=NULL, type="line", trend="FALSE", lowlim="<auto>", uplim="<auto>", logy=0, subset="") dialog.values <- getDialog("StatMedOrderedChart", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Ordered Chart")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Factors (pick zero or more)"), selectmode="multiple", listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="type", buttons=c("line", "box"), values=c("line", "box"), initialValue=dialog.values$type, labels=gettextRcmdr(c("Line", "Box")), title=gettextRcmdr("Plot type")) radioButtons(optionsFrame, name="trend", buttons=c("inc", "dec"), values=c("FALSE", "TRUE"), initialValue=dialog.values$trend, labels=gettextRcmdr(c("Increasing", "Decreasing")), title=gettextRcmdr("Order")) options2Frame <- tkframe(top) checkBoxes(frame="options2Frame", boxes=c("logy"),initialValues=dialog.values$logy,labels=gettextRcmdr(c("Log y-axis"))) options3Frame <- tkframe(top) lowlimFrame <- tkframe(options3Frame) lowlim <- tclVar(dialog.values$lowlim) lowlimField <- ttkentry(lowlimFrame, width="20", textvariable=lowlim) tkgrid(tklabel(lowlimFrame, text=gettextRcmdr("Y axis lower limit")), lowlimField, sticky="w") # tkgrid(lowlimFrame, sticky="w") uplimFrame <- tkframe(options3Frame) uplim <- tclVar(dialog.values$uplim) uplimField <- ttkentry(uplimFrame, width="20", textvariable=uplim) tkgrid(tklabel(uplimFrame, text=gettextRcmdr("Y axis upper limit")), uplimField, sticky="w") # tkgrid(uplimFrame, sticky="w") tkgrid(lowlimFrame, labelRcmdr(options3Frame, text=" "), uplimFrame, sticky="w") StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Ordered Chart"), "#####", sep="")) groups <- getSelection(groupBox) response <- getSelection(responseBox) ylog <- tclvalue(logyVariable) type <- as.character(tclvalue(typeVariable)) trend <- as.character(tclvalue(trendVariable)) lowlim <- tclvalue(lowlim) uplim <- tclvalue(uplim) .activeDataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) putDialog("StatMedOrderedChart", list(response=response, group=getSelection(groupBox), type=type, trend=trend, lowlim=lowlim, uplim=uplim, logy=ylog, subset=tclvalue(subsetVariable))) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { .subDataSet <- .activeDataSet } else { .subDataSet <- paste("subset(", .activeDataSet, ", ", subset, ")", sep="") } if (length(groups)==0) { groups <- "NULL" } else { groups <- paste(.subDataSet, "$", groups, sep="") } closeDialog() if (0 == length(response)) { errorCondition(recall=StatMedOrderedChart, message=gettextRcmdr("No response variable selected.")) return() } if (lowlim=="<auto>") lowlim <- NULL if (uplim=="<auto>") uplim <- NULL if (ylog==0){ ylog <- FALSE } else { ylog <- TRUE } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("OrderedPlot(y=", .subDataSet, "$", response, ", group=", groups, ', type="', type, '", ylab="', response, '", ylog=', ylog, ", lowlim=", lowlim, ", uplim=", uplim, ', decreasing="', trend, '")', sep="") doItAndPrint(command) activateMenus() tkfocus(CommanderWindow()) } buttonsFrame <- tkframe(top) OKCancelHelp(helpSubject="plot", apply="StatMedOrderedChart", reset="StatMedOrderedChart") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") # tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Grouping is valid only when line plot is selected."), fg="blue"), sticky="w") tkgrid(typeFrame, trendFrame, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(options2Frame, sticky="w") tkgrid(options3Frame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } StatMedSwimPlot <- function(){ defaults <- list(state=NULL, event=NULL, group=NULL, order=NULL, arrow=NULL, color=0) dialog.values <- getDialog("StatMedSwimPlot", defaults) env <- environment() initializeDialog(title=gettextRcmdr("Swimmer plot")) variablesFrame <- tkframe(top) variables2Frame <- tkframe(top) stateBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple", initialSelection=varPosn(dialog.values$state, "all"), title=gettextRcmdr("State variables"), listHeight=10) eventBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple", initialSelection=varPosn(dialog.values$event, "all"), title=gettextRcmdr("Event variables"), listHeight=10) arrowBox <- variableListBox(variables2Frame, Variables(), initialSelection=varPosn(dialog.values$arrow, "all"), title=gettextRcmdr("Variable for arrow (pick 0 for no arrow)"), listHeight=10) groupBox <- variableListBox(variables2Frame, Variables(), initialSelection=varPosn(dialog.values$group, "all"), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=10) orderBox <- variableListBox(variables2Frame, Variables(), initialSelection=varPosn(dialog.values$order, "all"), title=gettextRcmdr("Variable for sorting (pick 0 or 1)"), listHeight=10) checkBoxes(frame="color", boxes=c("color"),initialValues=dialog.values$color, labels=gettextRcmdr(c("Draw in color"))) onOK <- function(){ logger(paste("#####", gettextRcmdr("Swimmer plot"), "#####", sep="")) state <- getSelection(stateBox) event <- getSelection(eventBox) group <- getSelection(groupBox) order <- getSelection(orderBox) arrow <- getSelection(arrowBox) color <- tclvalue(colorVariable) closeDialog() putDialog("StatMedSwimPlot", list(state=state, event=event, group=group, order=order, arrow=arrow, color=color)) if (length(state) == 0) { errorCondition(recall=StatMedSwimPlot, message=gettextRcmdr("You must select a variable.")) return() } .activeDataSet <- ActiveDataSet() EndState <- NULL TimeEvent <- NULL for (i in 1:length(state)){ initializeDialog(subdialog, title=paste(gettextRcmdr("End of State: "), state[i], sep="")) endstateBox <- variableListBox(subdialog, Variables(), title=paste(gettextRcmdr("End of State:"), state[i], sep=""), listHeight=10) onOKsub <- function() { selection <- getSelection(endstateBox) closeDialog(subdialog) assign("selection", selection, envir=env) #send selection out of subdialog } subOKCancelHelp() tkgrid(getFrame(endstateBox), sticky="nw") tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subdialog, rows=6, columns=2, focus=subdialog, onOK=onOKsub, force.wait=TRUE) EndState[i] <- selection } if(length(event)>0){ for (i in 1:length(event)){ initializeDialog(subdialog, title=paste(gettextRcmdr("Time of Event:"), event[i], sep="")) timeeventBox <- variableListBox(subdialog, Variables(), title=paste(gettextRcmdr("Time of Event: "), event[i], sep=""), listHeight=10) onOKsub <- function() { selection <- getSelection(timeeventBox) closeDialog(subdialog) assign("selection", selection, envir=env) } subOKCancelHelp() tkgrid(getFrame(timeeventBox), sticky="nw") tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subdialog, rows=6, columns=2, focus=subdialog, onOK=onOKsub, force.wait=TRUE) TimeEvent[i] <- selection } } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SwimmerPlot(State=c('", paste(state, collapse="', '"), "'), EndState=c('", paste(EndState, collapse="', '"), "'), ", sep="") if (length(group)>0){ command <- paste(command, "Group='", group, "', ", sep="") } if (length(order)>0){ command <- paste(command, "Order='", order, "', ", sep="") } if (length(arrow)>0){ command <- paste(command, "Censored='", arrow, "', ", sep="") } if (color==0){ command <- paste(command, "Gray=1, ", sep="") } if (length(event)>0){ command <- paste(command, "Event=c('", paste(event, collapse="', '"), "'), TimeEvent=c('", paste(TimeEvent, collapse="', '"), "'), ", sep="") } command <- paste(command, "Dataset=", .activeDataSet, ")", sep="") doItAndPrint(command) } buttonsFrame <- tkframe(top) OKCancelHelp(helpSubject="swimmer_plot") tkgrid(labelRcmdr(top, text=gettextRcmdr("Select time variables after clicking OK."), fg="blue"), sticky = "nw") tkgrid(getFrame(stateBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky = "nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(arrowBox), labelRcmdr(variables2Frame, text=" "), getFrame(groupBox), getFrame(orderBox), sticky = "nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("Select a variable other than state or event variable for grouping and sorting."), fg="blue"), sticky = "nw") tkgrid(variables2Frame, sticky="nw") tkgrid(color, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") # dialogSuffix(rows=4, columns=2, preventGrabFocus=TRUE) dialogSuffix(rows=4, columns=2) } StatMedScatterPlot <- function () { # require("car") defaults <- list(initial.x = NULL, initial.y = NULL, initial.jitterx = 0, initial.jittery = 0, initial.logstringx = 0, initial.logstringy = 0, initial.log = 0, initial.box = 1, initial.line = 1, initial.smooth = 0, initial.spread = 0, initial.span = 50, initial.subset = gettext ("<all valid cases>"), initial.ylab = gettext ("<auto>"), initial.xlab = gettextRcmdr("<auto>"), initial.pch = gettextRcmdr("<auto>"), initial.cexValue = 1, initial.cex.axisValue = 1, initial.cex.labValue = 1, initialGroup=NULL, initial.lines.by.group=1, subset="") dialog.values <- getDialog("StatMedScatterPlot", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initial.group <- dialog.values$initial.group .linesByGroup <- if (dialog.values$initial.lines.by.group == 1) TRUE else FALSE .groups <- if (is.null(initial.group)) FALSE else initial.group Library("tcltk") initializeDialog(title = gettextRcmdr("Scatterplot")) .numeric <- Numeric() variablesFrame <- tkframe(top) xBox <- variableListBox(variablesFrame, .numeric, title = gettextRcmdr("x-variable (pick one)"), listHeight=6, initialSelection = varPosn (dialog.values$initial.x, "numeric")) yBox <- variableListBox(variablesFrame, .numeric, title = gettextRcmdr("y-variable (pick one)"), listHeight=6, initialSelection = varPosn (dialog.values$initial.y, "numeric")) optionsParFrame <- tkframe(top) checkBoxes(window = optionsParFrame, frame = "optionsFrame", boxes = c("identify", "jitterX", "jitterY", "logX", "logY", "boxplots", "lsLine", "smoothLine", "spread"), initialValues = c(dialog.values$initial.log, dialog.values$initial.jitterx, dialog.values$initial.jittery, dialog.values$initial.logstringx, dialog.values$initial.logstringy, dialog.values$initial.box, dialog.values$initial.line, dialog.values$initial.smooth, dialog.values$initial.spread),labels = gettextRcmdr(c("Identify points", "Jitter x-variable", "Jitter y-variable", "Log x-axis", "Log y-axis", "Marginal boxplots", "Least-squares line", "Smooth line", "Show spread")), title = "Options") sliderValue <- tclVar(dialog.values$initial.span) slider <- tkscale(optionsFrame, from = 0, to = 100, showvalue = TRUE, variable = sliderValue, resolution = 5, orient = "horizontal") # subsetBox(subset.expression = dialog.values$initial.subset) StatMedSubsetBox(model=TRUE) labelsFrame <- tkframe(top) xlabVar <- tclVar(dialog.values$initial.xlab) ylabVar <- tclVar(dialog.values$initial.ylab) xlabFrame <- tkframe(labelsFrame) xlabEntry <- ttkentry(xlabFrame, width = "25", textvariable = xlabVar) xlabScroll <- ttkscrollbar(xlabFrame, orient = "horizontal", command = function(...) tkxview(xlabEntry, ...)) tkconfigure(xlabEntry, xscrollcommand = function(...) tkset(xlabScroll, ...)) tkgrid(labelRcmdr(xlabFrame, text = gettextRcmdr("x-axis label"), fg = "blue"), sticky = "w") tkgrid(xlabEntry, sticky = "w") tkgrid(xlabScroll, sticky = "ew") ylabFrame <- tkframe(labelsFrame) ylabEntry <- ttkentry(ylabFrame, width = "25", textvariable = ylabVar) ylabScroll <- ttkscrollbar(ylabFrame, orient = "horizontal", command = function(...) tkxview(ylabEntry, ...)) tkconfigure(ylabEntry, xscrollcommand = function(...) tkset(ylabScroll, ...)) tkgrid(labelRcmdr(ylabFrame, text = gettextRcmdr("y-axis label"), fg = "blue"), sticky = "w") tkgrid(ylabEntry, sticky = "w") tkgrid(ylabScroll, sticky = "ew") tkgrid(xlabFrame, labelRcmdr(labelsFrame, text = " "), ylabFrame, sticky = "w") parFrame <- tkframe(optionsParFrame) pchVar <- tclVar(dialog.values$initial.pch) pchEntry <- ttkentry(parFrame, width = 25, textvariable = pchVar) cexValue <- tclVar(dialog.values$initial.cexValue) cex.axisValue <- tclVar(dialog.values$initial.cex.axisValue) cex.labValue <- tclVar(dialog.values$initial.cex.labValue) cexSlider <- tkscale(parFrame, from = 0.5, to = 2.5, showvalue = TRUE, variable = cexValue, resolution = 0.1, orient = "horizontal") cex.axisSlider <- tkscale(parFrame, from = 0.5, to = 2.5, showvalue = TRUE, variable = cex.axisValue, resolution = 0.1, orient = "horizontal") cex.labSlider <- tkscale(parFrame, from = 0.5, to = 2.5, showvalue = TRUE, variable = cex.labValue, resolution = 0.1, orient = "horizontal") onOK <- function() { logger(paste("#####", gettextRcmdr("Scatterplot"), "#####", sep="")) x <- getSelection(xBox) y <- getSelection(yBox) jitter <- if ("1" == tclvalue(jitterXVariable) && "1" == tclvalue(jitterYVariable)) ", jitter=list(x=1, y=1)" else if ("1" == tclvalue(jitterXVariable)) ", jitter=list(x=1)" else if ("1" == tclvalue(jitterYVariable)) ", jitter=list(y=1)" else "" logstring <- "" if ("1" == tclvalue(logXVariable)) logstring <- paste(logstring, "x", sep = "") if ("1" == tclvalue(logYVariable)) logstring <- paste(logstring, "y", sep = "") log <- tclvalue(identifyVariable) box <- tclvalue(boxplotsVariable) line <- tclvalue(lsLineVariable) smooth <- tclvalue(smoothLineVariable) spread <- tclvalue(spreadVariable) span <- as.numeric(tclvalue(sliderValue)) initial.subset <- subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) "" else paste(", subset=", subset, sep = "") cex.axis <- as.numeric(tclvalue(cex.axisValue)) cex <- as.numeric(tclvalue(cexValue)) cex.lab <- as.numeric(tclvalue(cex.labValue)) xlab <- trim.blanks(tclvalue(xlabVar)) xlab <- if (xlab == gettextRcmdr("<auto>")) "" else paste(", xlab=\"", xlab, "\"", sep = "") ylab <- trim.blanks(tclvalue(ylabVar)) ylab <- if (ylab == gettextRcmdr("<auto>")) "" else paste(", ylab=\"", ylab, "\"", sep = "") pch <- gsub(" ", ",", tclvalue(pchVar)) putDialog ("StatMedScatterPlot", list (initial.x = x, initial.y = y, initial.jitterx = tclvalue(jitterXVariable), initial.jittery = tclvalue(jitterYVariable), initial.logstringx = tclvalue(logXVariable), initial.logstringy = tclvalue(logYVariable), initial.log = log, initial.box = box, initial.line = line, initial.smooth = smooth, initial.spread = spread, initial.span = span, initial.subset = initial.subset, initial.xlab = tclvalue(xlabVar), initial.ylab = tclvalue(ylabVar), initial.cexValue = tclvalue(cexValue), initial.cex.axisValue = tclvalue(cex.axisValue), initial.cex.labValue = tclvalue(cex.labValue), initial.pch = pch, initial.group=if (.groups == FALSE) NULL else .groups, initial.lines.by.group=if (.linesByGroup) 1 else 0, subset=tclvalue(subsetVariable))) closeDialog() if ("" == pch) { errorCondition(recall = StatMedScatterPlot, message = gettextRcmdr("No plotting characters.")) return() } pch <- if (trim.blanks(pch) == gettextRcmdr("<auto>")) "" else paste(", pch=c(", pch, ")", sep = "") if (length(x) == 0 || length(y) == 0) { errorCondition(recall = StatMedScatterPlot, message = gettextRcmdr("You must select two variables")) return() } if (x == y) { errorCondition(recall = StatMedScatterPlot, message = gettextRcmdr("x and y variables must be different")) return() } .activeDataSet <- ActiveDataSet() log <- if (logstring != "") paste(", log=\"", logstring, "\"", sep = "") else "" if ("1" == tclvalue(identifyVariable)) { RcmdrTkmessageBox(title = "Identify Points", message = paste(gettextRcmdr("Use left mouse button to identify points,\n"), gettextRcmdr(if (MacOSXP()) "esc key to exit." else "right button to exit."), sep = ""), icon = "info", type = "ok") idtext <- ", id.method=\"identify\"" } else idtext <- "" box <- if ("1" == tclvalue(boxplotsVariable)) "'xy'" else "FALSE" line <- if ("1" == tclvalue(lsLineVariable)) "list(method=lm, lty=1)" else "FALSE" smooth <- as.character("1" == tclvalue(smoothLineVariable)) spread <- as.character("1" == tclvalue(spreadVariable)) cex <- if (cex == 1) "" else paste(", cex=", cex, sep = "") cex.axis <- if (cex.axis == 1) "" else paste(", cex.axis=", cex.axis, sep = "") cex.lab <- if (cex.lab == 1) "" else paste(", cex.lab=", cex.lab, sep = "") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (.groups == FALSE) { # doItAndPrint(paste("scatterplot(", y, "~", x, log, # ", reg.line=", line, ", smooth=", smooth, ", spread=", # spread, idtext, ", boxplots=", box, ", span=", # span/100, jitter, xlab, ylab, cex, cex.axis, # cex.lab, pch, ", data=", .activeDataSet, subset, # ")", sep = "")) doItAndPrint(paste("scatterplot(", y, "~", x, log, ", regLine=", line, if (smooth == "TRUE") paste0(", smooth=list(span=", span/100, ", spread=", spread, ")") else ", smooth=FALSE", idtext, ", boxplots=", box, jitter, xlab, ylab, cex, cex.axis, cex.lab, pch, ", data=", .activeDataSet, subset, ")", sep = "")) # Changted according to the updated car package } else { # doItAndPrint(paste("scatterplot(", y, "~", x, " | ", # .groups, log, ", reg.line=", line, ", smooth=", smooth, # ", spread=", spread, idtext, ", boxplots=", box, # ", span=", span/100, jitter, xlab, ylab, cex, # cex.axis, cex.lab, pch, ", by.groups=", .linesByGroup, # ", data=", .activeDataSet, subset, ")", sep = "")) doItAndPrint(paste("scatterplot(", y, "~", x, " | ", .groups, log, ", regLine=", line, if (smooth == "TRUE") paste0(", smooth=list(span=", span/100, ", spread=", spread, ")") else ", smooth=FALSE", idtext, ", boxplots=", box, jitter, xlab, ylab, cex, cex.axis, cex.lab, pch, ", by.groups=", .linesByGroup, ", data=", .activeDataSet, subset, ")", sep = "")) # Changted according to the updated car package } activateMenus() tkfocus(CommanderWindow()) } groupsBox(scatterPlot, plotLinesByGroup = TRUE, initialGroup=initial.group, initialLinesByGroup=dialog.values$initial.lines.by.group, initialLabel=if (is.null(initial.group)) gettextRcmdr("Plot by groups") else paste(gettextRcmdr("Plot by:"), initial.group)) OKCancelHelp(helpSubject = "scatterplot", apply = "StatMedScatterPlot", reset = "StatMedScatterPlot") tkgrid(getFrame(xBox), getFrame(yBox), sticky = "nw") tkgrid(variablesFrame, sticky = "w") tkgrid(labelRcmdr(optionsFrame, text = gettextRcmdr("Span for smooth")), slider, sticky = "w") tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Plotting Parameters"), fg = "blue"), sticky = "w") tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Plotting characters")), pchEntry, stick = "w") tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Point size")), cexSlider, sticky = "w") tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Axis text size")), cex.axisSlider, sticky = "w") tkgrid(labelRcmdr(parFrame, text = gettextRcmdr("Axis-labels text size")), cex.labSlider, sticky = "w") tkgrid(optionsFrame, parFrame, sticky = "nw") tkgrid(optionsParFrame, sticky = "w") tkgrid(labelsFrame, sticky = "w") tkgrid(subsetFrame, sticky = "w") tkgrid(groupsFrame, sticky = "w") tkgrid(labelRcmdr(top, text = " ")) tkgrid(buttonsFrame, columnspan = 2, sticky = "w") dialogSuffix(rows = 8, columns = 2) } StatMedScatterPlotMatrix <- function () { # require("car") defaults <- list(initial.variables = NULL, initial.line = 1, initial.smooth = 0, initial.spread = 0, initial.span = 50, initial.diag = "density", initial.subset = gettext ("<all valid cases>"), initialGroup=NULL, initial.lines.by.group=1, subset="") dialog.values <- getDialog("StatMedScatterPlotMatrix", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initial.group <- dialog.values$initial.group .linesByGroup <- if (dialog.values$initial.lines.by.group == 1) TRUE else FALSE .groups <- if (is.null(initial.group)) FALSE else initial.group Library("tcltk") initializeDialog(title = gettextRcmdr("Scatterplot Matrix")) variablesBox <- variableListBox(top, Numeric(), title = gettextRcmdr("Select variables (three or more)"), selectmode = "multiple", listHeight=10, initialSelection = varPosn (dialog.values$initial.variables, "numeric")) checkBoxes(frame = "optionsFrame", boxes = c("lsLine", "smoothLine", "spread"), initialValues = c(dialog.values$initial.line, dialog.values$initial.smooth, dialog.values$initial.spread), labels = gettextRcmdr(c("Least-squares lines", "Smooth lines", "Show spread"))) sliderValue <- tclVar(dialog.values$initial.span) slider <- tkscale(optionsFrame, from = 0, to = 100, showvalue = TRUE, variable = sliderValue, resolution = 5, orient = "horizontal") radioButtons(name = "diagonal", buttons = c("density", "histogram", "boxplot", "oned", "qqplot", "none"), labels = gettextRcmdr(c("Density plots", "Histograms", "Boxplots", "One-dimensional scatterplots", "Normal QQ plots", "Nothing (empty)")), title = gettextRcmdr("On Diagonal"), initialValue = dialog.values$initial.diag) # subsetBox(subset.expression = dialog.values$initial.subset) StatMedSubsetBox(model=TRUE) onOK <- function() { logger(paste("#####", gettextRcmdr("Scatterplot Matrix"), "#####", sep="")) variables <- getSelection(variablesBox) closeDialog() line <- if ("1" == tclvalue(lsLineVariable)) "list(method=lm, lty=1)" else "FALSE" smooth <- as.character("1" == tclvalue(smoothLineVariable)) spread <- as.character("1" == tclvalue(spreadVariable)) span <- as.numeric(tclvalue(sliderValue)) diag <- as.character(tclvalue(diagonalVariable)) initial.subset <- subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) "" else paste(", subset=", subset, sep="") .activeDataSet <- ActiveDataSet() putDialog("StatMedScatterPlotMatrix", list(initial.variables = variables, initial.line = tclvalue (lsLineVariable), initial.smooth = tclvalue(smoothLineVariable),initial.spread = tclvalue (spreadVariable), initial.span = span, initial.diag = diag, initial.subset = initial.subset, initial.group=if (.groups == FALSE) NULL else .groups, initial.lines.by.group=if (.linesByGroup) 1 else 0, subset=tclvalue(subsetVariable))) if (length(variables) < 3) { errorCondition(recall = StatMedScatterPlotMatrix, message = gettextRcmdr("Fewer than 3 variable selected.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (.groups == FALSE) { # command <- paste("scatterplotMatrix(~", paste(variables, # collapse = "+"), ", reg.line=", line, ", smooth=", # smooth, ", spread=", spread, ", span=", span/100, # ", diagonal = '", diag, "', data=", .activeDataSet, # subset, ")", sep = "") command <- paste("scatterplotMatrix(~", paste(variables, collapse = "+"), ", regLine=", line, if (smooth == "TRUE") paste0(", smooth=list(span=", span/100, ", spread=", spread, ")") else ", smooth=FALSE", ", diagonal = '", diag, "', data=", .activeDataSet, subset, ")", sep = "") # Changted according to the updated car package logger(command) justDoIt(command) } else { # command <- paste("scatterplotMatrix(~", paste(variables, # collapse = "+"), " | ", .groups, ", reg.line=", # line, ", smooth=", smooth, ", spread=", spread, # ", span=", span/100, ", diagonal= '", diag, "', by.groups=", # .linesByGroup, ", data=", .activeDataSet, subset, # ")", sep = "") command <- paste("scatterplotMatrix(~", paste(variables, collapse = "+"), " | ", .groups, ", regLine=", line, if (smooth == "TRUE") paste0(", smooth=list(span=", span/100, ", spread=", spread, ")") else ", smooth=FALSE", ", diagonal= '", diag, "', by.groups=", .linesByGroup, ", data=", .activeDataSet, subset, ")", sep = "") # Changted according to the updated car package logger(command) justDoIt(command) } activateMenus() tkfocus(CommanderWindow()) } groupsBox(scatterPlot, plotLinesByGroup = TRUE, initialGroup=initial.group, initialLinesByGroup=dialog.values$initial.lines.by.group, initialLabel=if (is.null(initial.group)) gettextRcmdr("Plot by groups") else paste(gettextRcmdr("Plot by:"), initial.group)) OKCancelHelp(helpSubject = "scatterplotMatrix", apply = "StatMedScatterPlotMatrix", reset = "StatMedScatterPlotMatrix") tkgrid(getFrame(variablesBox), sticky = "nw") tkgrid(labelRcmdr(optionsFrame, text = gettextRcmdr("Span for smooth")), slider, sticky = "w") tkgrid(optionsFrame, sticky = "w") tkgrid(diagonalFrame, sticky = "w") tkgrid(subsetFrame, sticky = "w") tkgrid(groupsFrame, sticky = "w") tkgrid(buttonsFrame, columnspan = 2, sticky = "w") dialogSuffix(rows = 6, columns = 2) } StatMedPlotMeans <- function(){ defaults <- list(group=NULL, response=NULL, errorBars="sd", confidence="0.95", graph="narrow", line="color", subset = "") dialog.values <- getDialog("StatMedPlotMeans", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Plot Means")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Factors (pick one or two)"), selectmode="multiple", listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Plot Means"), "#####", sep="")) groups <- getSelection(groupBox) response <- getSelection(responseBox) graph <- as.character(tclvalue(graphVariable)) error.bars <- tclvalue(errorBarsVariable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } line <- tclvalue(lineVariable) if (line=="color") line <- ", lty=1, lwd=1, " if (line=="type") line <- ", col=1, lwd=1, " if (line=="width") line <- ", col=1, lty=1, " putDialog("StatMedPlotMeans", list(group=groups, response=response, errorBars=error.bars, confidence=as.character(tclvalue(levelVariable)), graph=graph, line=tclvalue(lineVariable), subset = tclvalue(subsetVariable))) closeDialog() if (0 == length(groups)) { errorCondition(recall=StatMedPlotMeans, message=gettextRcmdr("No factors selected.")) return() } if (2 < length(groups)) { errorCondition(recall=StatMedPlotMeans, message=gettextRcmdr("More than two factors selected.")) return() } if (0 == length(response)) { errorCondition(recall=StatMedPlotMeans, message=gettextRcmdr("No response variable selected.")) return() } .activeDataSet <- ActiveDataSet() level <- if (error.bars == "conf.int") paste(", level=", tclvalue(levelVariable), sep="") else "" if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (length(groups) == 1) doItAndPrint(paste("StatMedplotMeans(", subset1, .activeDataSet, subset2, "$", response, ", factor(", subset1, .activeDataSet, subset2, "$", groups[1], '), error.bars="', error.bars, '"', level, ', xlab="', groups[1], '", ylab="', response, '")', sep="")) else { if (graph == "narrow"){ if (eval(parse(text=paste("length(levels(", subset1, .activeDataSet, subset2, "$", groups[1], ")) < length(levels(", subset1, .activeDataSet, subset2, "$", groups[2], "))", sep="")))) groups <- rev(groups) doItAndPrint(paste("StatMedplotMeans(", subset1, .activeDataSet, subset2, "$", response, ", as.factor(", subset1, .activeDataSet, subset2, "$", groups[1], "), as.factor(", subset1, .activeDataSet, subset2, "$", groups[2], '), error.bars="', error.bars, '"', level, ', xlab="', groups[1], '"', line, 'ylab="', response, '", legend.lab="', groups[2], '")', sep="")) } else{ doItAndPrint(paste("dummyfactor <- paste(as.factor(", subset1, .activeDataSet, subset2, "$", groups[1], '), " : ", as.factor(', .activeDataSet, "$", groups[2], '), sep="")', sep="")) doItAndPrint(paste('xlab <- paste("', groups[1], '", " : ", "', groups[2], '", sep="")')) doItAndPrint(paste("StatMedplotMeans(", subset1, .activeDataSet, subset2, "$", response, ', as.factor(dummyfactor), error.bars="', error.bars, '"', line, level, ', xlab=xlab, ylab="', response, '")', sep="")) } } activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="plotMeans", apply="StatMedPlotMeans", reset="StatMedPlotMeans") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="errorBars", buttons=c("se", "sd", "conf.int", "none"), values=c("se", "sd", "conf.int", "none"), initialValue=dialog.values$errorBars, labels=gettextRcmdr(c("Standard errors", "Standard deviations", "Confidence intervals", "No error bars")), title=gettextRcmdr("Error Bars")) levelFrame <- tkframe(optionsFrame) levelVariable <- tclVar(dialog.values$confidence) levelField <- ttkentry(levelFrame, width="6", textvariable=levelVariable) tkgrid(labelRcmdr(levelFrame, text=gettextRcmdr(" Level of confidence:")), levelField, sticky="w") tkgrid(errorBarsFrame, labelRcmdr(optionsFrame, text=gettextRcmdr(" ")), levelFrame, sticky="w") tkgrid(optionsFrame, columnspan=2, sticky="w") options2Frame <- tkframe(top) radioButtons(options2Frame, name="graph", buttons=c("narrow", "wide"), values=c("narrow", "wide"), initialValue=dialog.values$graph, labels=gettextRcmdr(c("Narrow view", "Wide view")), title=gettextRcmdr("When two factors were picked:")) radioButtons(options2Frame, name="line", buttons=c("color", "type", "width"), values=c("color", "type", "width"), initialValue=dialog.values$line, labels=gettextRcmdr(c("Color", "Line type", "Line width")), title=gettextRcmdr("Line discrimination")) tkgrid(graphFrame, labelRcmdr(options2Frame, text=" "), lineFrame, sticky="w") tkgrid(options2Frame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } StatMedLinePlot <- function(){ defaults <- list(data=NULL, group=NULL, axisLabel="", log=0, multi=0, subset = "") dialog.values <- getDialog("StatMedLinePlot", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Line graph(Repeated measures)")) variablesFrame <- tkframe(top) dataBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Repeatedly measured data (pick at least 2)"), selectmode="multiple", listHeight=15, initialSelection=varPosn(dialog.values$data, "numeric")) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) axisLabelFrame <- tkframe(top) axisLabelVariable <- tclVar(dialog.values$axisLabel) axisLabelField <- ttkentry(axisLabelFrame, width="40", textvariable=axisLabelVariable) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("log", "multi"), initialValues=c(dialog.values$log, dialog.values$multi),labels=gettextRcmdr(c("Log y-axis", "Show different groups in separate graphs"))) # logFrame <- tkframe(top) # logVariable <- tclVar("0") # logCheckBox <- tkcheckbutton(logFrame, variable=logVariable) # multiFrame <- tkframe(top) # multiVariable <- tclVar("0") # multiCheckBox <- tkcheckbutton(multiFrame, variable=multiVariable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Line graph(Repeated measures)"), "#####", sep="")) dataSet <- ActiveDataSet() data <- getSelection(dataBox) group <- getSelection(groupBox) axisLabel <- tclvalue(axisLabelVariable) logy <- tclvalue(logVariable) multi <- tclvalue(multiVariable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } putDialog("StatMedLinePlot", list(data=data, group=group, axisLabel=axisLabel, log=logy, multi=multi, subset = tclvalue(subsetVariable)) ) closeDialog() ndata <- length(data) if (ndata < 2) { errorCondition(recall=StatMedLinePlot, message=gettextRcmdr("Pick at least 2 repeatedly measured data")) return() } command <- paste("alldata <- c(", subset1, dataSet, subset2, "$", data[1], sep="") command2 <- paste('xlabels <- c("', data[1], '"', sep="") for (i in 2:ndata){ command <- paste(command, ", ", subset1, dataSet, subset2, "$", data[i], sep="") command2 <- paste(command2, ', "', data[i], '"', sep="") } command <- paste(command, ")", sep="") command2 <- paste(command2, ")", sep="") doItAndPrint(command) doItAndPrint(command2) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (logy==0){ logy <- "" doItAndPrint("ylimu <- max(alldata, na.rm=TRUE)") doItAndPrint("yliml <- ylimu - (ylimu - min(alldata, na.rm=TRUE))*1.2") doItAndPrint("ylimu <- ylimu*1.2") } else{ logy <- ', log="y"' doItAndPrint("ylimu <- max(alldata, na.rm=TRUE)") doItAndPrint("yliml <- min(alldata, na.rm=TRUE)") } if (axisLabel == gettextRcmdr("<use y-variable names>")){ axisLabel <- if (legend) "" else if(length(y) == 1) y else paste(paste("(", 1:length(y), ") ", y, sep=""), collapse=", ") } if (length(group) == 0){ command <- paste("y <- rbind(", subset1, dataSet, subset2, "$", data[1], sep="") for (i in 2:ndata){ command <- paste(command, ", ", subset1, dataSet, subset2, "$", data[i], sep="") } command <- paste(command, ")", sep="") doItAndPrint(command) command <- paste('matplot(y, type="o", lty=1, pch=1, col=1, ylab="', axisLabel, '", ylim=c(yliml, ylimu), axes=FALSE', logy, ")", sep="") doItAndPrint(command) doItAndPrint("box()") doItAndPrint("axis(2)") doItAndPrint(paste("axis(1, at=1:", ndata, ", labels=xlabels)", sep="")) } if (length(group) == 1){ groups <- eval(parse(text=paste("levels(factor(", subset1, dataSet, subset2, "$", group, "))", sep=""))) ngroup <- length(groups) groupmembers <- paste('c("', groups[1], '"', sep="") if (ngroup >= 2){ for (i in 2:ngroup){ groupmembers <- paste(groupmembers, ', "', groups[i], '"', sep="") } } groupmembers <- paste(groupmembers, ')', sep="") command <- paste("y <- rbind(", subset1, dataSet, subset2, "[", subset1, dataSet, subset2, "$", group, '=="', groups[1], '",]$', data[1], sep="") for (i in 2:ndata){ command <- paste(command, ", ", subset1, dataSet, subset2, "[", subset1, dataSet, subset2, "$", group, '=="', groups[1], '",]$', data[i], sep="") } command <- paste(command, ")", sep="") doItAndPrint(command) command <- paste('matplot(y, type="o", lty=1, pch=1, col=1, ylab="', axisLabel, '", ylim=c(yliml, ylimu), axes=FALSE', logy, ")", sep="") doItAndPrint(command) doItAndPrint("box()") doItAndPrint("axis(2)") doItAndPrint(paste("axis(1, at=1:", ndata, ", labels=xlabels)", sep="")) if (ngroup >= 2){ if (multi == 1){ doItAndPrint(paste('legend("topright", "', group, "=", groups[1], '", box.lty=0)', sep="")) } else { command <- paste('legend("topright", ', groupmembers, ", col=1:", ngroup, ", lty=1:", ngroup, ", lwd=1:", ngroup, ', title="', group, '", box.lty=0)', sep="") doItAndPrint(command) } for (j in 2:ngroup){ command <- paste("y <- rbind(", subset1, dataSet, subset2, "[", subset1, dataSet, subset2, "$", group, '=="', groups[j], '",]$', data[1], sep="") for (i in 2:ndata){ command <- paste(command, ", ", subset1, dataSet, subset2, "[", subset1, dataSet, subset2, "$", group, '=="', groups[j], '",]$', data[i], sep="") } command <- paste(command, ")", sep="") doItAndPrint(command) if (multi == 1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste('matplot(y, type="o", lty=1, pch=1, col=1, ylab="', axisLabel, '", ylim=c(yliml, ylimu), axes=FALSE', logy, ")", sep="") doItAndPrint(command) doItAndPrint("box()") doItAndPrint("axis(2)") doItAndPrint(paste("axis(1, at=1:", ndata, ", labels=xlabels)", sep="")) doItAndPrint(paste('legend("topright", "', group, "=", groups[j], '", box.lty=0)', sep="")) } else { command <- paste('matplot(y, type="o", lty=', j, ", pch=", j, ", lwd=", j, ", col=", j, ', ylab="', axisLabel, '", ylim=c(yliml, ylimu), axes=FALSE', logy, ", add=TRUE)", sep="") doItAndPrint(command) } } } } activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="matplot", apply="StatMedLinePlot", reset="StatMedLinePlot") tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(dataBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(axisLabelFrame, text=paste(gettextRcmdr("Label for y-axis"), ": "), fg="blue"), axisLabelField, sticky="w") # tkgrid(axisLabelEntry, sticky="w") tkgrid(axisLabelFrame, sticky="w") # tkgrid(labelRcmdr(logFrame, text=gettextRcmdr("Log y-axis")), # logCheckBox, sticky="w") # tkgrid(logFrame, sticky="w") # tkgrid(labelRcmdr(multiFrame, text=gettextRcmdr("Show different groups in separate graphs")), # multiCheckBox, sticky="w") # tkgrid(multiFrame, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, stick="w") dialogSuffix(rows=4, columns=1) } StatMedMeanCI <- function(){ initializeDialog(title=gettextRcmdr("Confidence interval for a mean")) variableFrame <- tkframe(top) mean <- tclVar("") meanEntry <- ttkentry(variableFrame, width="20", textvariable=mean) sd <- tclVar("") sdEntry <- ttkentry(variableFrame, width="20", textvariable=sd) variable2Frame <- tkframe(top) sample <- tclVar("") sampleEntry <- ttkentry(variable2Frame, width="20", textvariable=sample) CI <- tclVar("95") CIEntry <- ttkentry(variable2Frame, width="20", textvariable=CI) onOK <- function(){ logger(paste("#####", gettextRcmdr("Confidence interval for a mean"), "#####", sep="")) mean <- tclvalue(mean) sd <- tclvalue(sd) sample <- tclvalue(sample) CI <- tclvalue(CI) closeDialog() if (length(mean) == 0 || length(sd) == 0 || length(sample) == 0){ errorCondition(recall=StatMedMeanCI, message=gettextRcmdr("You must select a variable.")) return() } doItAndPrint(paste("se <- ", sd, "/ sqrt(", sample, ")", sep="")) doItAndPrint(paste("CIL <- ", mean, " - qt((100+", CI, ")/200, ", sample, "-1)*se", sep="")) doItAndPrint(paste("CIH <- ", mean, " + qt((100+", CI, ")/200, ", sample, "-1)*se", sep="")) doItAndPrint(paste('cat("', CI, '", gettextRcmdr("%CI"), " ", round(CIL,3), "-", round(CIH,3), "\n", sep="")')) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="epi.tests") tkgrid(tklabel(variableFrame, text=gettextRcmdr("Mean")), meanEntry, sticky="w") tkgrid.configure(meanEntry, sticky="w") tkgrid(tklabel(variableFrame, text=gettextRcmdr("Standard deviation")), sdEntry, sticky="w") tkgrid.configure(sdEntry, sticky="w") tkgrid(tklabel(variable2Frame, text=gettextRcmdr("Sample size")), sampleEntry, sticky="w") tkgrid.configure(sampleEntry, sticky="w") tkgrid(tklabel(variable2Frame, text=gettextRcmdr("Confidence interval")), CIEntry, sticky="w") tkgrid.configure(CIEntry, sticky="w") tkgrid(variableFrame, sticky="nw") tkgrid(variable2Frame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSG <- function(){ initializeDialog(title=gettextRcmdr("Smirnov-Grubbs test for outliers")) variableBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)"), listHeight=15) radioButtons(name="remove", buttons=c("no", "yes"), values=c("0", "1"), labels=gettextRcmdr(c("No", "Yes")), title=gettextRcmdr("Create a variable converting outliers to NA")) newName <- tclVar(gettextRcmdr("<same as variables>")) newNameField <- ttkentry(top, width="20", textvariable=newName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Smirnov-Grubbs test for outliers"), "#####", sep="")) variables <- getSelection(variableBox) closeDialog() if (length(variables) == 0) { errorCondition(recall=StatMedSG, message=gettextRcmdr("You must select a variable.")) return() } newname <- trim.blanks(tclvalue(newName)) remove <- tclvalue(removeVariable) .activeDataSet <- ActiveDataSet() if(remove==1){ for (name in variables){ nname <- if (newname == gettextRcmdr("<same as variables>")) name else if (length(variables) == 1) newname else paste(newname, name, sep="") if (!is.valid.name(nname)){ errorCondition(recall=StatMedSG, message=paste('"', nname, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(nname, Variables())) { if ("no" == tclvalue(checkReplace(nname))){ StatMedSG() return() } } command <- paste("(", .activeDataSet, "$", nname, " <- RemoveOutlier(", .activeDataSet, "$", name, ", return=1))", sep="") result <- doItAndPrint(command) if (class(result)[1] != "try-error") activeDataSet(.activeDataSet, flushModel=FALSE) } tkfocus(CommanderWindow()) } else { for (name in variables){ command <- paste("RemoveOutlier(", .activeDataSet, "$", name, ", return=0)", sep="") doItAndPrint(command) } } } OKCancelHelp() tkgrid(getFrame(variableBox), removeFrame, sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("New variable name or prefix for multiple variables:")), newNameField, sticky="w") tkgrid(buttonsFrame, sticky="w", columnspan=2) dialogSuffix(rows=4, columns=2, preventGrabFocus=TRUE) } StatMedSingleSampleTTest <- function(){ defaults <- list(x=NULL, mu="0.0", confidence="0.95", alternative="two.sided", subset = "") dialog.values <- getDialog("StatMedSingleSampleTTest", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Single-Sample t-Test")) xBox <- variableListBox(top, Numeric(), title=gettextRcmdr("Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$x, "numeric")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Single-Sample t-Test"), "#####", sep="")) x <- getSelection(xBox) alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceVariable) mu <- tclvalue(muVariable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } putDialog("StatMedSingleSampleTTest", list(x=x, mu=mu, confidence=tclvalue(confidenceVariable), alternative=alternative, subset = tclvalue(subsetVariable))) if (length(x) == 0){ errorCondition(recall=StatMedSingleSampleTTest, message=gettextRcmdr("You must select a variable.")) return() } closeDialog() doItAndPrint("res <- NULL") doItAndPrint(paste("(res <- t.test(", subset1, ActiveDataSet(), subset2, "$", x, ", alternative='", alternative, "', mu=", mu, ", conf.level=", level, "))", sep="")) doItAndPrint('cat(gettextRcmdr( "mean"), " = ", res$estimate, ", ", gettextRcmdr( "95% CI"), " ", res$conf.int[1], "-", res$conf.int[2], ", ", gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n", sep="")') # doItAndPrint("remove(res)") tkdestroy(top) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="t.test", apply="StatMedSingleSampleTTest", reset="StatMedSingleSampleTTest") radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"),initialValue=dialog.values$alternative, labels=gettextRcmdr(c("Population mean != mu0", "Population mean < mu0", "Population mean > mu0")), title=gettextRcmdr("Alternative Hypothesis")) rightFrame <- tkframe(top) confidenceFrame <- tkframe(rightFrame) confidenceVariable <- tclVar(dialog.values$confidence) confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceVariable) muFrame <- tkframe(rightFrame) muVariable <- tclVar(dialog.values$mu) muField <- ttkentry(muFrame, width="6", textvariable=muVariable) # confidenceFrame <- tkframe(rightFrame) # confidenceLevel <- tclVar(".95") # confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceLevel) # muFrame <- tkframe(rightFrame) # muVariable <- tclVar("0.0") # muField <- ttkentry(muFrame, width="8", textvariable=muVariable) tkgrid(getFrame(xBox), sticky="nw") tkgrid(labelRcmdr(rightFrame, text=""), sticky="w") tkgrid(labelRcmdr(muFrame, text=gettextRcmdr("Null hypothesis: mu = ")), muField, sticky="w") tkgrid(muFrame, sticky="w") tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level: ")), confidenceField, sticky="w") tkgrid(confidenceFrame, sticky="w") tkgrid(alternativeFrame, sticky="nw") tkgrid(rightFrame, sticky="nw") tkgrid.configure(confidenceField, sticky="e") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=4, columns=2) } StatMedKS <- function(){ initializeDialog(title=gettextRcmdr("Kolmogorov-smirnov test for normal distribution")) variablesFrame <- tkframe(top) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Variable (pick one)"), listHeight=15) StatMedSubsetBox() onOK <- function(){ logger(paste("#####", gettextRcmdr("Kolmogorov-smirnov test for normal distribution"), "#####", sep="")) response <- getSelection(responseBox) if (length(response) == 0) { errorCondition(recall=StatMedKS, message=gettextRcmdr("You must select a response variable.")) return() } subset <- tclvalue(subsetVariable) .activeDataSet <- ActiveDataSet() if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset <- .activeDataSet } else { subset <- paste("subset(", .activeDataSet, ", ", subset, ")", sep="") } closeDialog() if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("hist2(", subset, "$", response, ', freq=F, main="", xlab="', response, '", ylab="", col="darkgray")', sep="") doItAndPrint(command) command <- paste("curve(dnorm(x, mean=mean(", subset, "$", response, "[!is.na(", subset, "$", response, ")]), sd=sd(", subset, "$", response, "[!is.na(", subset, "$", response, ")])), add=T)", sep="") doItAndPrint(command) doItAndPrint(paste("skewness.kurtosis(", subset, "$", response, ")", sep="")) doItAndPrint(paste("ks.test(", subset, "$", response, ', "pnorm", mean=mean(', subset, "$", response, "[!is.na(", subset, "$", response, ")]), sd=sd(", subset, "$", response, "[!is.na(", subset, "$", response, ")]))", sep="")) n <- eval(parse(text=paste("length(", subset, "$", response, ")", sep=""))) logger(paste(gettextRcmdr("# Shapiro-Wilk test can be performed only when the sample size is less than 5000. (Sample size ="), " ", n, ")", sep="")) if(n <= 5000){ doItAndPrint(paste("shapiro.test(", subset, "$", response, ")", sep="")) } tkfocus(CommanderWindow()) tkdestroy(top) } OKCancelHelp(helpSubject="ks.test") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1) } StatMedFTest <- function(){ defaults <- list(group=NULL, response=NULL, confidence="0.95", alternative="two.sided", subset = "") dialog.values <- getDialog("StatMedFTest", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Two-variances F-test")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Groups (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Two-variances F-test"), "#####", sep="")) group <- getSelection(groupBox) response <- getSelection(responseBox) alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceVariable) .activeDataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset3 <- .activeDataSet subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset3 <- paste("subset(", .activeDataSet, ", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedFTest", list(group=group, response=response, confidence=level, alternative=alternative, subset = tclvalue(subsetVariable))) if (length(group) == 0) { errorCondition(recall=StatMedFTest, message=gettextRcmdr("You must select a groups variable.")) return() } if (length(response) == 0) { errorCondition(recall=StatMedFTest, message=gettextRcmdr("You must select a response variable.")) return() } closeDialog() levels <- eval(parse(text=paste("with(droplevels(", subset3, "), length(levels(as.factor(", group, "))))", sep=""))) if(levels!=2){ errorCondition(recall=StatMedFTest, message=gettextRcmdr("You must select a variable with two levels.")) return() } doItAndPrint(paste("tapply(", subset1, .activeDataSet, subset2, "$", response, ", ", subset1, .activeDataSet, subset2, "$", group, ", var, na.rm=TRUE)", sep="")) doItAndPrint("res <- NULL") doItAndPrint(paste("(res <- var.test(", response, " ~ ", group, ", alternative='", alternative, "', conf.level=", level, ", data=", .activeDataSet, subset, "))", sep="")) doItAndPrint('cat(gettextRcmdr( "F test"), " ", gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n", sep="")') # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) tkdestroy(top) } OKCancelHelp(helpSubject="var.test", apply="StatMedFTest", reset="StatMedFTest") radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), initialValue=dialog.values$alternative, labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) confidenceFrame <- tkframe(top) confidenceVariable <- tclVar(dialog.values$confidence) confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceVariable) tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="w") # groupsLabel(groupsBox=groupBox) tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level: "), fg="blue"), confidenceField, sticky="w") tkgrid(alternativeFrame, sticky="w") tkgrid(confidenceFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1) } StatMedBartlett <- function(){ defaults <- list(group=NULL, response=NULL, subset = "") dialog.values <- getDialog("StatMedBartlett", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Bartlett's test")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Groups (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Bartlett's test"), "#####", sep="")) group <- getSelection(groupBox) response <- getSelection(responseBox) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedBartlett", list(group=group, response=response, subset = tclvalue(subsetVariable))) if (length(group) == 0) { errorCondition(recall=StatMedBartlett, message=gettextRcmdr("You must select a groups variable.")) return() } if (length(response) == 0) { errorCondition(recall=StatMedBartlett, message=gettextRcmdr("You must select a response variable.")) return() } closeDialog() .activeDataSet <- ActiveDataSet() doItAndPrint(paste("tapply(", subset1, .activeDataSet, subset2, "$", response, ", ", subset1, .activeDataSet, subset2, "$", group, ", var, na.rm=TRUE)", sep="")) doItAndPrint("res <- NULL") doItAndPrint(paste("(res <- bartlett.test(", response, " ~ ", group, ", data=", .activeDataSet, subset, "))", sep="")) doItAndPrint('cat(gettextRcmdr( "Bartlett test"), " ", gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n", sep="")') # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) tkdestroy(top) } OKCancelHelp(helpSubject="bartlett.test", apply="StatMedBartlett", reset="StatMedBartlett") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="w") # groupsLabel(groupsBox=groupBox) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=5, columns=1) } StatMedTtest <- function(){ defaults <- list(group=NULL, response=NULL, confidence="0.95", alternative="two.sided", variances="TRUE", graph="bar", subset = "") dialog.values <- getDialog("StatMedTtest", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Two-sample t-test")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(),selectmode="multiple", title=gettextRcmdr("Grouping variables with two levels (pick at least one)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) #change to "multiple" to accept analyses for multiple factors #change to "Variables()" to accept numeric variabels as grouping variable responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Two-sample t-test"), "#####", sep="")) group <- getSelection(groupBox) response <- getSelection(responseBox) alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceVariable) variances <- as.character(tclvalue(variancesVariable)) graph <- as.character(tclvalue(graphVariable)) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset3 <- ActiveDataSet() subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset3 <- paste("subset(", ActiveDataSet(), ", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedTtest", list(group=group, response=response, confidence=tclvalue(confidenceVariable), alternative=alternative, variances=variances, graph=graph, subset = tclvalue(subsetVariable))) if (length(group) == 0) { errorCondition(recall=StatMedTtest, message=gettextRcmdr("You must select a groups variable.")) return() } if (length(response) == 0) { errorCondition(recall=StatMedTtest, message=gettextRcmdr("You must select a response variable.")) return() } closeDialog() nvar = length(group) doItAndPrint("group.names <- NULL") doItAndPrint("group.means <- NULL") doItAndPrint("group.sds <- NULL") doItAndPrint("group.p <- NULL") for (i in 1:nvar) { levels <- eval(parse(text=paste("with(droplevels(", subset3, "), length(levels(as.factor(", group[i], "))))", sep=""))) if(levels!=2){ errorCondition(recall=StatMedTtest, message=gettextRcmdr("You must select a variable with two levels.")) return() } doItAndPrint("res <- NULL") doItAndPrint(paste("(res <- t.test(", response, "~factor(", group[i], "), alternative='", alternative, "', conf.level=", level, ", var.equal=", variances, ", data=", ActiveDataSet(), subset, "))", sep="")) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (graph == "box"){ command <- (paste("boxplot(", response, "~ factor(", group[i], '), ylab="', response, '", xlab="', group[i], '"', ", data=", ActiveDataSet(), subset, ")", sep="")) logger(command) justDoIt(command) } if (graph == "point"){ command <- paste("StatMedplotMeans(", subset1, ActiveDataSet(), subset2, "$", response, ", factor(", subset1, ActiveDataSet(), subset2, "$", group[i], '), ylab="', response, '", xlab="', group[i], '", error.bars="sd", level=0.95)', sep="") logger(command) justDoIt(command) } doItAndPrint(paste("bar.means <- tapply(", subset1, ActiveDataSet(), subset2, "$", response, ", factor(", subset1, ActiveDataSet(), subset2, "$", group[i], "), mean, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.sds <- tapply(", subset1, ActiveDataSet(), subset2, "$", response, ", factor(", subset1, ActiveDataSet(), subset2, "$", group[i], "), sd, na.rm=TRUE)", sep="")) if (graph == "bar"){ doItAndPrint("bar.sds <- ifelse(is.na(bar.sds), 0, bar.sds)") doItAndPrint(paste('barx <- barplot(bar.means, ylim=c(ifelse(min(bar.means, na.rm=TRUE)>0, 0, min(bar.means-bar.sds, na.rm=TRUE)*1.2), max(bar.means+bar.sds, na.rm=TRUE)*1.2), xlab="', group[i], '", ylab="', response, '", axis.lty=1)',sep="")) doItAndPrint(paste("error.bar(barx, bar.means, bar.sds)", sep="")) } group.levels <- eval(parse(text=paste("levels(factor(", subset1, ActiveDataSet(), subset2, "$", group[i], "))", sep=""))) for (j in 1:2){ doItAndPrint(paste('group.names <- c(group.names, "', group[i], "=", group.levels[j], '")', sep="")) doItAndPrint(paste("group.means <- c(group.means, bar.means[", j, "])", sep="")) doItAndPrint(paste("group.sds <- c(group.sds, bar.sds[", j, "])", sep="")) if (j == 1){ doItAndPrint("group.p <- c(group.p, signif(res$p.value,digits=3))") } else { doItAndPrint('group.p <- c(group.p, "")') } } # doItAndPrint("remove(res)") } doItAndPrint("summary.ttest <- NULL") doItAndPrint("summary.ttest <- data.frame(mean=group.means, sd=group.sds, p.value=group.p)") doItAndPrint("rownames(summary.ttest) <- group.names") doItAndPrint('colnames(summary.ttest) <- gettextRcmdr(colnames(summary.ttest))') doItAndPrint("summary.ttest") # doItAndPrint("remove(summary.ttest)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="t.test", apply="StatMedTtest", reset="StatMedTtest") optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), initialValue=dialog.values$alternative,labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) confidenceFrame <- tkframe(optionsFrame) confidenceVariable <- tclVar(dialog.values$confidence) confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceVariable) radioButtons(optionsFrame, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue=dialog.values$variances, labels=gettextRcmdr(c("Yes (t-test)", "No (Welch test)")), title=gettextRcmdr("Assume equal variances?")) radioButtons(optionsFrame, name="graph", buttons=c("box", "bar", "point"), values=c("box", "bar", "point"), initialValue=dialog.values$graph, labels=gettextRcmdr(c("BoxGraph", "BarGraph", "LinePlot")), title=gettextRcmdr("Graphs")) tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue")) tkgrid(confidenceField, sticky="w") groupsLabel(groupsBox=groupBox) tkgrid(alternativeFrame, labelRcmdr(optionsFrame, text=" "), confidenceFrame, labelRcmdr(optionsFrame, text=" "), variancesFrame, labelRcmdr(optionsFrame, text=" "), graphFrame, sticky="nw") tkgrid(optionsFrame, sticky="nw") # tkgrid(confidenceFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedPairedTtest <- function(){ defaults <- list(xBox=NULL, yBox=NULL, confidence="0.95", alternative="two.sided", subset = "") dialog.values <- getDialog("StatMedPairedTtest", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Paired t-test")) .numeric <- Numeric() variablesFrame <- tkframe(top) xBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("First variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$xBox, "numeric")) yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Second variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$yBox, "numeric")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Paired t-test"), "#####", sep="")) x <- getSelection(xBox) y <- getSelection(yBox) alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceVariable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } putDialog("StatMedPairedTtest", list(xBox=x, yBox=y, confidence=level, alternative=alternative, subset = tclvalue(subsetVariable))) if (length(x) == 0 | length(y) == 0){ errorCondition(recall=StatMedPairedTtest, message=gettextRcmdr("You must select two variables.")) return() } if (x == y){ errorCondition(recall=StatMedPairedTtest, message=gettextRcmdr("Variables must be different.")) return() } closeDialog() .activeDataSet <- ActiveDataSet() doItAndPrint(paste("(res <- t.test(", subset1, .activeDataSet, subset2, "$", x, ", ", subset1, .activeDataSet, subset2, "$", y, ", alternative='", alternative, "', conf.level=", level, ", paired=TRUE))", sep="")) doItAndPrint(paste("mean1 <- mean(", subset1, .activeDataSet, subset2, "$", x, ", na.rm=TRUE)", sep="")) doItAndPrint(paste("mean2 <- mean(", subset1, .activeDataSet, subset2, "$", y, ", na.rm=TRUE)", sep="")) doItAndPrint(paste("sd1 <- sd(", subset1, .activeDataSet, subset2, "$", x, ", na.rm=TRUE)", sep="")) doItAndPrint(paste("sd2 <- sd(", subset1, .activeDataSet, subset2, "$", y, ", na.rm=TRUE)", sep="")) doItAndPrint("summary.ttest <- NULL") doItAndPrint('summary.ttest <- data.frame(mean=c(mean1, mean2), sd=c(sd1, sd2), p.value=c(signif(res$p.value, digit=3),""))') doItAndPrint(paste('rownames(summary.ttest) <- c("', x, '", "', y, '")', sep="")) doItAndPrint('colnames(summary.ttest) <- gettextRcmdr(colnames(summary.ttest))') doItAndPrint("summary.ttest") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="t.test", apply="StatMedPairedTtest", reset="StatMedPairedTtest") radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), initialValue=dialog.values$alternative, labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) confidenceFrame <- tkframe(top) confidenceVariable <- tclVar(dialog.values$confidence) confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceVariable) tkgrid(getFrame(xBox), labelRcmdr(variablesFrame, text=" "), getFrame(yBox), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level"), fg="blue")) tkgrid(confidenceField, sticky="w") tkgrid(alternativeFrame, sticky="nw") tkgrid(confidenceFrame, sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } StatMedANOVA <- function(){ Library("multcomp") Library("abind") defaults <- list(group=NULL, response=NULL, variances="TRUE", pairwise=0, dunnett=0, bonferroni=0, holm=0, actmodel=0, graph="bar", subset = "") dialog.values <- getDialog("StatMedANOVA", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("One-way ANOVA")) UpdateModelNumber() modelName <- tclVar(paste("AnovaModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Grouping variables (pick at least one)"), listHeight=12, initialSelection=varPosn(dialog.values$group, "all")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=12, initialSelection=varPosn(dialog.values$response, "numeric")) #tkgrid(labelRcmdr(top, text=gettextRcmdr("Pairwise comparison not performed when more than one grouping variables are picked."), fg="blue"), sticky="w") optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("bonferroni", "holm", "pairwise", "dunnett"), initialValues=c(dialog.values$bonferroni, dialog.values$holm, dialog.values$pairwise, dialog.values$dunnett),labels=gettextRcmdr(c("Pairwise comparison (Bonferroni)", "Pairwise comparison (Holm)","Pairwise comparison (Tukey)", "Pairwise comparison (Dunnett)"))) #tkgrid(labelRcmdr(top, text=gettextRcmdr("The first group in alphabetical will be treated as the reference group."), fg="blue"), sticky="w") options2Frame <- tkframe(top) checkBoxes(frame="options2Frame", boxes="actmodel", initialValues=dialog.values$actmodel,labels=gettextRcmdr("Keep results as active model for further analyses")) # pairwiseVariable <- tclVar("0") # pairwiseCheckBox <- tkcheckbutton(optionsFrame, variable=pairwiseVariable) # dunnettVariable <- tclVar("0") # dunnettCheckBox <- tkcheckbutton(optionsFrame, variable=dunnettVariable) # bonferroniVariable <- tclVar("0") # bonferroniCheckBox <- tkcheckbutton(optionsFrame, variable=bonferroniVariable) # holmVariable <- tclVar("0") # holmCheckBox <- tkcheckbutton(optionsFrame, variable=holmVariable) # actmodelVariable <- tclVar("0") # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("One-way ANOVA"), "#####", sep="")) modelValue <- trim.blanks(tclvalue(modelName)) group <- getSelection(groupBox) response <- getSelection(responseBox) variances <- as.character(tclvalue(variancesVariable)) graph <- as.character(tclvalue(graphVariable)) pairwise <- tclvalue(pairwiseVariable) dunnett <- tclvalue(dunnettVariable) bonferroni <- tclvalue(bonferroniVariable) holm <- tclvalue(holmVariable) actmodel <- tclvalue(actmodelVariable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedANOVA", list(group=group, response=response, variances=variances, pairwise=pairwise, dunnett=dunnett, bonferroni=bonferroni, holm=holm, actmodel=actmodel, graph=graph, subset=tclvalue(subsetVariable))) if (!is.valid.name(modelValue)){ UpdateModelNumber(-1) errorCondition(recall=StatMedANOVA, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue)) return() } if (is.element(modelValue, listAOVModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) tkdestroy(top) oneWayAnova() return() } } closeDialog() if (length(group) == 0){ errorCondition(recall=StatMedANOVA, message=gettextRcmdr("You must select a groups factor.")) return() } if (length(response) == 0){ errorCondition(recall=StatMedANOVA, message=gettextRcmdr("You must select a response variable.")) return() } .activeDataSet <- ActiveDataSet() nvar = length(group) doItAndPrint("group.names <- NULL") doItAndPrint("group.means <- NULL") doItAndPrint("group.sds <- NULL") doItAndPrint("group.p <- NULL") for (i in 1:nvar) { if(variances=="TRUE"){ command <- paste(modelValue, " <- aov(", response, " ~ factor(", group[i], "), data=", .activeDataSet, subset, ", na.action=na.omit)", sep="") justDoIt(command) logger(command) } # assign(modelValue, justDoIt(command), envir=.GlobalEnv) # doItAndPrint(paste("numSummary(", subset1, .activeDataSet, subset2, "$", response, " , groups=", subset1, .activeDataSet, subset2, "$", group[i], ', statistics=c("mean", "sd"))', sep="")) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} #bar.means and bar.sds are required to show summary.anova even for "box" or "point" doItAndPrint(paste("bar.means <- tapply(", subset1, ActiveDataSet(), subset2, "$", response, ", factor(", subset1, ActiveDataSet(), subset2, "$", group[i], "), mean, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.sds <- tapply(", subset1, ActiveDataSet(), subset2, "$", response, ", factor(", subset1, ActiveDataSet(), subset2, "$", group[i], "), sd, na.rm=TRUE)", sep="")) if (graph == "box"){ command <- (paste("boxplot(", response, "~ factor(", group[i], '), ylab="', response, '", xlab="', group[i], '"', ", data=", ActiveDataSet(), subset, ")", sep="")) logger(command) justDoIt(command) } if (graph == "point"){ command <- paste("StatMedplotMeans(", subset1, ActiveDataSet(), subset2, "$", response, ", factor(", subset1, ActiveDataSet(), subset2, "$", group[i], '), ylab="', response, '", xlab="', group[i], '", error.bars="sd", level=0.95)', sep="") logger(command) justDoIt(command) } if (graph == "bar"){ doItAndPrint( 'error.bar <- function(x, y, upper, lower=upper, length=0.1,...){ if(length(x) != length(y) | length(y) !=length(lower) | length(lower) != length(upper)) stop("vectors must be same length") arrows(x,y+upper, x, y-lower, angle=90, code=3, length=length, ...) }') doItAndPrint(paste('barx <- barplot(bar.means, ylim=c(ifelse(min(bar.means, na.rm=TRUE)>0, 0, min(bar.means-bar.sds, na.rm=TRUE)*1.2), max(bar.means+bar.sds, na.rm=TRUE)*1.2), xlab="', group[i], '", ylab="', response, '", axis.lty=1)',sep="")) doItAndPrint(paste("error.bar(barx, bar.means, bar.sds)", sep="")) } group.levels <- eval(parse(text=paste("levels(factor(", subset1, ActiveDataSet(), subset2, "$", group[i], "))", sep=""))) for (j in 1:length(group.levels)){ doItAndPrint(paste('group.names <- c(group.names, "', group[i], "=", group.levels[j], '")', sep="")) doItAndPrint(paste("group.means <- c(group.means, bar.means[", j, "])", sep="")) doItAndPrint(paste("group.sds <- c(group.sds, bar.sds[", j, "])", sep="")) if (j == 1 & variances=="TRUE"){ doItAndPrint("res <- NULL") doItAndPrint(paste("res <- summary(lm(", response, " ~ factor(", group[i], "), data=", .activeDataSet, subset, "))", sep="")) doItAndPrint('group.p <- c(group.p, signif(pf(res$fstatistic[1], res$fstatistic[2], res$fstatistic[3], lower.tail=FALSE), digits=3))') #doItAndPrint("remove(res)") } else if(j == 1 & variances=="FALSE"){ doItAndPrint(paste("res <- oneway.test(", response, " ~ factor(", group[i], "), data=", .activeDataSet, subset, ", var.equal=FALSE)", sep="")) doItAndPrint('group.p <- c(group.p, signif(res$p.value, digits=3))') } else { doItAndPrint('group.p <- c(group.p, "")') } } if(variances=="TRUE") doItAndPrint(paste("summary(", modelValue, ")", sep="")) } doItAndPrint("summary.anova <- NULL") doItAndPrint("summary.anova <- data.frame(mean=group.means, sd=group.sds, p.value=group.p)") doItAndPrint("rownames(summary.anova) <- group.names") doItAndPrint('colnames(summary.anova) <- gettextRcmdr(colnames(summary.anova))') doItAndPrint("summary.anova") # doItAndPrint("remove(summary.anova)") if (bonferroni == 1 && nvar == 1 && variances=="TRUE"){ dataSet=ActiveDataSet() doItAndPrint(paste("pairwise.t.test(", subset1, dataSet, subset2, "$", response, ", ", subset1, dataSet, subset2, "$", group, ", var.equal=", variances, ', p.adj="bonferroni")', sep="")) } if (holm == 1 && nvar == 1 && variances=="TRUE"){ dataSet=ActiveDataSet() doItAndPrint(paste("pairwise.t.test(", subset1, dataSet, subset2, "$", response, ", ", subset1, dataSet, subset2, "$", group, ", var.equal=", variances, ', p.adj="holm")', sep="")) } if (pairwise == 1 && nvar == 1 && variances=="TRUE") { if (eval(parse(text=paste("length(levels(factor(", subset1, .activeDataSet, subset2, "$", group, "))) < 3")))) Message(message=gettextRcmdr("Factor has fewer than 3 levels; pairwise comparisons omitted."), type="warning") # the following lines modified by Richard Heiberger and subsequently by J. Fox else { # command <- paste(".Pairs <- glht(", modelValue, ", linfct = mcp(", group, ' = "Tukey"))', sep="") command <- paste("TukeyHSD(", modelValue, ', "factor(', group, ')")', sep="") doItAndPrint(command) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("plot(TukeyHSD(", modelValue, ', "factor(', group, ')"))', sep="") doItAndPrint(command) # doItAndPrint("confint(.Pairs) # confidence intervals") # doItAndPrint("cld(.Pairs) # compact letter display") # justDoIt("old.oma <- par(oma=c(0,5,0,0))") # logger("old.oma <- par(oma=c(0,5,0,0))") # justDoIt("plot(confint(.Pairs))") # logger("plot(confint(.Pairs))") # justDoIt("par(old.oma)") # logger("par(old.oma)") # logger("remove(.Pairs)") # remove(.Pairs, envir=.GlobalEnv) } } if (dunnett == 1 && nvar == 1 && variances=="TRUE"){ doItAndPrint(paste("group.factor <- factor(", subset1, .activeDataSet, subset2, "$", group, ")", sep="")) command <- paste("res <- aov(", response, " ~ group.factor, data=", .activeDataSet, subset, ")", sep="") doItAndPrint(command) command <- 'summary(glht(res, linfct=mcp(group.factor="Dunnett")))' doItAndPrint(command) } if (actmodel==1) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="anova", model=TRUE, apply="StatMedANOVA", reset="StatMedANOVA") tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model: ")), model, sticky="w") tkgrid(modelFrame, sticky="w", columnspan=2) tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="w") options0Frame <- tkframe(top) radioButtons(options0Frame, name="graph", buttons=c("box", "bar", "point"), values=c("box", "bar", "point"), initialValue=dialog.values$graph, labels=gettextRcmdr(c("BoxGraph", "BarGraph", "LinePlot")), title=gettextRcmdr("Graphs")) radioButtons(options0Frame, name="variances", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue=dialog.values$variances, labels=gettextRcmdr(c("Yes (ANOVA)", "No (Welch test)")), title=gettextRcmdr("Assume equal variances?")) tkgrid(graphFrame, labelRcmdr(options0Frame, text=" "), variancesFrame, sticky="nw") tkgrid(options0Frame, sticky="nw") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison not performed when more than one grouping variables are picked."), fg="blue"), sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Bonferroni)")), bonferroniCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Holm)")), holmCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Tukey)")), pairwiseCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Dunnett)")), dunnettCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("The first group in alphabetical will be treated as the reference group."), fg="blue"), sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Keep results as active model for further analyses")), actmodelCheckBox, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Pairwise comparison and active model keeping not performed for Welch test."), fg="blue"), sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Pairwise comparison not performed when more than one grouping variables are picked."), fg="blue"), sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(labelRcmdr(top, text=gettextRcmdr("The first group in alphabetical will be treated as the reference group."), fg="blue"), sticky="w") tkgrid(options2Frame, sticky="w", columnspan=2) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=4, columns=2) } StatMedRepANOVA <- function(){ defaults <- list(group=NULL, data=NULL, line="color", bonferroni=0, holm=0, actmodel=0, subset = "") dialog.values <- getDialog("StatMedRepANOVA", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Repeated-measures ANOVA")) UpdateModelNumber() modelName <- tclVar(paste("AnovaModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) variablesFrame <- tkframe(top) dataBox <- variableListBox(variablesFrame, Numeric(),selectmode="multiple", title=gettextRcmdr("Repeatedly measured data (pick at least 2)"), listHeight=15, initialSelection=varPosn(dialog.values$data, "numeric")) groupBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Grouping variable (pick 0, 1, or more)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("bonferroni", "holm", "actmodel"), initialValues=c(dialog.values$bonferroni, dialog.values$holm, dialog.values$actmodel),labels=gettextRcmdr(c("Pairwise comparison (Bonferroni)", "Pairwise comparison (Holm)", "Keep results as active model for further analyses"))) # bonferroniVariable <- tclVar("0") # bonferroniCheckBox <- tkcheckbutton(optionsFrame, variable=bonferroniVariable) # holmVariable <- tclVar("0") # holmCheckBox <- tkcheckbutton(optionsFrame, variable=holmVariable) # actmodelVariable <- tclVar("0") # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Repeated-measures ANOVA"), "#####", sep="")) modelValue <- trim.blanks(tclvalue(modelName)) data <- getSelection(dataBox) group <- getSelection(groupBox) bonferroni <- tclvalue(bonferroniVariable) holm <- tclvalue(holmVariable) actmodel <- tclvalue(actmodelVariable) dataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { doItAndPrint(paste("TempDF <- ", dataSet)) } else { doItAndPrint(paste("TempDF <- subset(", dataSet, ",", subset, ")") ) } line <- tclvalue(lineVariable) if (line=="color") line <- ", lty=1, lwd=1" if (line=="type") line <- ", col=1, lwd=1" if (line=="width") line <- ", col=1, lty=1" putDialog("StatMedRepANOVA", list(group=group, data=data, line=tclvalue(lineVariable), bonferroni=bonferroni, holm=holm, actmodel=actmodel, subset = tclvalue(subsetVariable))) if (!is.valid.name(modelValue)){ UpdateModelNumber(-1) errorCondition(recall=StatMedRepANOVA, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue)) return() } if (is.element(modelValue, listLMModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) tkdestroy(top) StatMedRepANOVA() return() } } if (length(data) < 2) { errorCondition(recall=StatMedRepANOVA, message=gettextRcmdr("You must select a response variable.")) return() } closeDialog() nvar <- length(data) RepeatedData <- data[1] RepeatedData2 <- paste('"', data[1], '"', sep="") for(i in 2:nvar){ RepeatedData <- paste(RepeatedData, ", ", data[i], sep="") RepeatedData2 <- paste(RepeatedData2, ', "', data[i], '"', sep="") } nvar2 <- length(group) if (nvar2 >= 1){ for(i in 1:nvar2){ doItAndPrint(paste("TempDF$Factor", i, ".", group[i], " <- factor(TempDF$", group[i], ")", sep="")) doItAndPrint(paste("contrasts(TempDF$Factor", i, ".", group[i], ') <- "contr.Sum"', sep="")) } } if(nvar2 == 0){ factors <- "1" } if(nvar2 == 1){ factors <- paste("Factor1.", group[1], sep="") } if(nvar2 >= 2){ factors <- paste("Factor1.", group[1], sep="") for(i in 2:nvar2){ factors <- paste(factors, "*Factor", i, ".", group[i], sep="") } } logger("#Convert to long format to draw graph") doItAndPrint("n <- length(TempDF[,1])") doItAndPrint("TempDF$TempID <- c(1:n)") command <- "TempDF2 <- data.frame(TempID=TempDF$TempID" for (i in 1:nvar){ command <- paste(command, ", ", data[i], "=TempDF$", data[i], sep="") } if (length(group) == 0){ } else{ for (i in 1:length(group)){ command <- paste(command, ", ", group[i], "=TempDF$", group[i], sep="") } } command <- paste(command, ")", sep="") doItAndPrint(command) doItAndPrint("TempDF2 <- na.omit(TempDF2)") #delete rows with NA command <- paste('TempDF3 <- reshape(TempDF2, idvar="TempID", varying=list(c("', data[1], sep="") for (i in 2:nvar){ command <- paste(command, '", "', data[i], sep="") } command <- paste(command, '")), v.names="data", direction="long")', sep="") doItAndPrint(command) command <- paste('RepeatNumber <- c("', data[1], sep="") for (i in 2:nvar){ command <- paste(command, '", "', data[i], sep="") } command <- paste(command, '")', sep="") doItAndPrint(command) doItAndPrint("nvar <- length(TempDF3$time)") doItAndPrint("for (i in 1:nvar){TempDF3$time2[i] <- RepeatNumber[TempDF3$time[i]]}") if (length(group) == 0){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint('StatMedplotMeans(TempDF3$data, factor(TempDF3$time2), error.bars="sd", xlab="", ylab="")') } if (length(group) == 1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint(paste("StatMedplotMeans(TempDF3$data, factor(TempDF3$time2), factor(TempDF3$", group[1], '), error.bars="sd", xlab="", ylab="", legend.lab="', group[1], '", ', line, ")", sep="")) } if (length(group) == 2){ doItAndPrint(paste("for (i in 1:length(levels(factor(TempDF3$", group[1], ")))){windows(); par(", par.option, "); StatMedplotMeans(TempDF3$data[TempDF3$", group[1], "==levels(factor(TempDF3$", group[1], "))[i]], factor(TempDF3$time2[TempDF3$", group[1], "==levels(factor(TempDF3$", group[1], "))[i]]), factor(TempDF3$", group[2], "[TempDF3$", group[1], "==levels(factor(TempDF3$", group[1], "))[i]]), error.bars=", '"sd", xlab="", ylab="", legend.lab="', group[2], '", main=paste("', group[1], '", " : ", levels(factor(TempDF3$', group[1], "))[i]), ", line, ")}", sep="")) } command <- paste("lm(cbind(", RepeatedData, ") ~ ", factors, ", data=TempDF, na.action=na.omit)", sep="") # logger(paste(modelValue, " <- ", command, sep = "")) # assign(modelValue, justDoIt(command), envir = .GlobalEnv) doItAndPrint(paste(modelValue, " <- ", command, sep = "")) doItAndPrint(paste("time <- factor(c(", RepeatedData2, "))", sep="")) doItAndPrint("time <- data.frame(Time = time)") doItAndPrint("res <- NULL") doItAndPrint(paste("res <- Anova(", modelValue, ', idata=time, idesign=~Time, type="III")', sep="")) if (actmodel==1) activeModel(modelValue) doItAndPrint("summary(res, multivariate=FALSE)") if (bonferroni == 1 && length(group) == 0){ command <- paste("pairwise.pairedt.test(with(TempDF, cbind(", RepeatedData, ')), group=NULL, "', dataSet, '", p.adjust.method="bonferroni")', sep="") doItAndPrint(command) } if (bonferroni == 1 && length(group) == 1){ command <- paste("pairwise.pairedt.test(with(TempDF, cbind(", RepeatedData, ")), TempDF$", factors, ', "', dataSet, '", p.adjust.method="bonferroni")', sep="") doItAndPrint(command) } if (holm == 1 && length(group) == 0){ command <- paste("pairwise.pairedt.test(with(TempDF, cbind(", RepeatedData, ')), group=NULL, "', dataSet, '", p.adjust.method="holm")', sep="") doItAndPrint(command) } if (holm == 1 && length(group) == 1){ command <- paste("pairwise.pairedt.test(with(TempDF, cbind(", RepeatedData, ")), TempDF$", factors, ', "', dataSet, '", p.adjust.method="holm")', sep="") doItAndPrint(command) } # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Anova", model=TRUE, apply="StatMedRepANOVA", reset="StatMedRepANOVA") tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model: ")), model, sticky="w") tkgrid(modelFrame, sticky="w", columnspan=2) tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(dataBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("Graph not created when 3 or more grouping variables are picked.")), sticky="w") radioButtons(name="line", buttons=c("color", "type", "width"), values=c("color", "type", "width"), initialValue=dialog.values$line, labels=gettextRcmdr(c("Color", "Line type", "Line width")), title=gettextRcmdr("Line discrimination")) tkgrid(lineFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Pairwise comparison not performed when more than one grouping variables are picked."), fg="blue"), sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Bonferroni)")), bonferroniCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Holm)")), holmCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Keep results as active model for further analyses")), actmodelCheckBox, sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedMultiANOVA <- function(){ defaults <- list(group=NULL, data=NULL, interaction=1, actmodel=0, subset = "") dialog.values <- getDialog("StatMedMultiANOVA", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Multi-way ANOVA")) UpdateModelNumber() modelName <- tclVar(paste("AnovaModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) variablesFrame <- tkframe(top) dataBox <- variableListBox(variablesFrame, Numeric(),title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$data, "numeric")) groupBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Factors (pick one or more)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) optionsFrame <- tkframe(top) # checkBoxes(window=optionsFrame, frame="interaction", boxes=c("interaction"),initialValues=c(1),labels=gettextRcmdr(c("Include interaction term (when less than 4 grouping variables are picked)"))) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes="interaction", initialValues=dialog.values$interaction,labels=gettextRcmdr("Include interaction term (when less than 4 grouping variables are picked)")) options2Frame <- tkframe(top) checkBoxes(frame="options2Frame", boxes="actmodel", initialValues=dialog.values$actmodel,labels=gettextRcmdr("Keep results as active model for further analyses")) # interactionVariable <- tclVar("1") # interactionCheckBox <- tkcheckbutton(optionsFrame, variable=interactionVariable) # actmodelVariable <- tclVar("0") # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Multi-way ANOVA"), "#####", sep="")) modelValue <- trim.blanks(tclvalue(modelName)) data <- getSelection(dataBox) group <- getSelection(groupBox) dataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { doItAndPrint(paste("TempDF <- ", dataSet)) } else { doItAndPrint(paste("TempDF <- subset(", dataSet, ",", subset, ")") ) } interaction <- tclvalue(interactionVariable) actmodel <- tclvalue(actmodelVariable) putDialog("StatMedMultiANOVA", list(group=group, data=data, interaction=interaction, actmodel=actmodel, subset = tclvalue(subsetVariable))) if (!is.valid.name(modelValue)){ UpdateModelNumber(-1) errorCondition(recall=StatMedMultiANOVA, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue)) return() } if (is.element(modelValue, listLMModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) tkdestroy(top) StatMedMultiANOVA() return() } } if (length(data) == 0) { errorCondition(recall=StatMedMultiANOVA, message=gettextRcmdr("You must select a response variable.")) return() } if (length(group) == 0) { errorCondition(recall=StatMedMultiANOVA, message=gettextRcmdr("You must select at least one factor.")) return() } closeDialog() nvar <- length(group) if (nvar <=3 & interaction==1){ mark <- "*" } else { mark <- "+" } if (nvar >= 1){ for(i in 1:nvar){ doItAndPrint(paste("TempDF$Factor", i, ".", group[i], " <- factor(TempDF$", group[i], ")", sep="")) doItAndPrint(paste("contrasts(TempDF$Factor", i, ".", group[i], ') <- "contr.Sum"', sep="")) } } if(nvar == 1){ factors <- paste(" + Factor1.", group[1], sep="") } if(nvar >= 2){ factors <- paste(" + Factor1.", group[1], sep="") for (i in 2:nvar){ factors <- paste(factors, mark, "Factor", i, ".", group[i], sep="") } } if (nvar == 1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint(paste("bar.means <- tapply(TempDF$", data, ", TempDF$", group[1], ", mean, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.sds <- tapply(TempDF$", data, ", TempDF$", group[1], ", sd, na.rm=TRUE)", sep="")) doItAndPrint("bar.sds <- ifelse(is.na(bar.sds), 0, bar.sds)") doItAndPrint(paste('barx <- barplot(bar.means, ylim=c(ifelse(min(bar.means)>0, 0, min(bar.means-bar.sds)*1.2), max(bar.means+bar.sds)*1.2), xlab="', group[1], '", ylab="', data, '", axis.lty=1)',sep="")) doItAndPrint(paste("error.bar(barx, bar.means, bar.sds)", sep="")) } if (nvar == 2){ if (eval(parse(text=paste("min(table(TempDF$", group[1], ", TempDF$", group[2], "))", sep="")))==0) { logger(gettextRcmdr("Graph not created when a group with 0 sample exists")) } else { eval.bar.var <- eval(parse(text=paste("length(levels(factor(TempDF$", group[2], ")))", sep=""))) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint(paste("bar.var <- length(levels(factor(TempDF$", group[2], ")))", sep="")) doItAndPrint(paste("bar.sums <- tapply(subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[1])$", data, ", subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[1])$", group[1], ", sum, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.means <- tapply(subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[1])$", data, ", subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[1])$", group[1], ", mean, na.rm=TRUE)", sep="")) doItAndPrint(paste("bar.sds <- tapply(subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[1])$", data, ", subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[1])$", group[1], ", sd, na.rm=TRUE)", sep="")) if(eval.bar.var > 1){ for (i in 2: eval.bar.var){ doItAndPrint(paste("bar.sums <- c(bar.sums, tapply(subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[", i, "])$", data, ", subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[", i, "])$", group[1], ", sum, na.rm=TRUE))", sep="")) doItAndPrint(paste("bar.means <- c(bar.means, tapply(subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[", i, "])$", data, ", subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[", i, "])$", group[1], ", mean, na.rm=TRUE))", sep="")) doItAndPrint(paste("bar.sds <- c(bar.sds, tapply(subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[", i, "])$", data, ", subset(TempDF, ", group[2], "==levels(factor(", group[2], "))[", i, "])$", group[1], ", sd, na.rm=TRUE))", sep="")) doItAndPrint("bar.n <- bar.sums/bar.means") doItAndPrint("bar.ses <- bar.sds/sqrt(bar.n)") } } doItAndPrint(paste("bar.var2 <- length(levels(factor(TempDF$", group[1], ")))", sep="")) doItAndPrint("bar.means <- matrix(bar.means, bar.var2)") doItAndPrint("bar.sds <- matrix(bar.sds, bar.var2)") doItAndPrint("bar.ses <- matrix(bar.ses, bar.var2)") doItAndPrint("bar.sds <- ifelse(is.na(bar.sds), 0, bar.sds)") doItAndPrint("bar.ses <- ifelse(is.na(bar.ses), 0, bar.ses)") doItAndPrint(paste('barx <- barplot(bar.means, beside=TRUE, ylim=c(ifelse(min(bar.means)>0, 0, min(bar.means-bar.sds)*1.2), max(bar.means+bar.sds)*1.2), xlab="', group[2], '", ylab="', data, '", names.arg=levels(factor(TempDF$', group[2], ")), legend.text=levels(factor(TempDF$", group[1], ')), args.legend=list(title="', group[1], '", box.lty=0), axis.lty=1)', sep="")) doItAndPrint("error.bar(barx, bar.means, bar.sds)") } } groups.list <- paste(paste(group, "=TempDF$", group, sep=""), collapse=", ") doItAndPrint(paste("tapply(TempDF$", data, ", list(", groups.list, "), mean, na.rm=TRUE) # means", sep="")) doItAndPrint(paste("tapply(TempDF$", data, ", list(", groups.list, "), sd, na.rm=TRUE) # std. deviations", sep="")) doItAndPrint(paste("tapply(TempDF$", data, ", list(", groups.list, "), function(x) sum(!is.na(x))) # counts", sep="")) command <- paste("lm(", data, " ~ 1", factors, ", data=TempDF, na.action=na.omit)", sep="") # logger(paste(modelValue, " <- ", command, sep = "")) # assign(modelValue, justDoIt(command), envir = .GlobalEnv) doItAndPrint(paste(modelValue, " <- ", command, sep = "")) # doItAndPrint("library(car)") doItAndPrint(paste("Anova(", modelValue, ', type="III")', sep="")) if (actmodel==1) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Anova", model=TRUE, apply="StatMedMultiANOVA", reset="StatMedMultiANOVA") tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model: ")), model, sticky="w") tkgrid(modelFrame, sticky="w", columnspan=2) tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(dataBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") # tkgrid(labelRcmdr(optionsFrame, text=""), interaction, sticky="w") tkgrid(optionsFrame, sticky="nw") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Include interaction term (when less than 4 grouping variables are picked)")), interactionCheckBox, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Graph not created when 3 or more grouping variables are picked.")), sticky="w") tkgrid(options2Frame, sticky="nw") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Keep results as active model for further analyses")), actmodelCheckBox, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedANCOVA <- function(){ defaults <- list(group=NULL, data=NULL, covariate=NULL, actmodel=0, subset = "") dialog.values <- getDialog("StatMedANCOVA", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("ANCOVA")) UpdateModelNumber() modelName <- tclVar(paste("AnovaModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) variablesFrame <- tkframe(top) dataBox <- variableListBox(variablesFrame, Numeric(),title=gettextRcmdr("Response Variable (pick one)"), listHeight=10, initialSelection=varPosn(dialog.values$data, "numeric")) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable (pick one)"), listHeight=10, initialSelection=varPosn(dialog.values$group, "all")) variables2Frame <- tkframe(top) covariateBox <- variableListBox(variables2Frame, Numeric(), title=gettextRcmdr("Numeric variable for adjustment (pick one)"), listHeight=10, initialSelection=varPosn(dialog.values$covariate, "numeric")) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes="actmodel", initialValues=dialog.values$actmodel,labels=gettextRcmdr("Keep results as active model for further analyses")) # actmodelVariable <- tclVar("0") # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("ANCOVA"), "#####", sep="")) modelValue <- trim.blanks(tclvalue(modelName)) data <- getSelection(dataBox) group <- getSelection(groupBox) covariate <- getSelection(covariateBox) dataSet <- ActiveDataSet() actmodel <- tclvalue(actmodelVariable) subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { doItAndPrint(paste("TempDF <- ", dataSet)) } else { doItAndPrint(paste("TempDF <- subset(", dataSet, ",", subset, ")") ) } putDialog("StatMedANCOVA", list(group=group, data=data, covariate=covariate, actmodel=actmodel, subset = tclvalue(subsetVariable))) if (!is.valid.name(modelValue)){ UpdateModelNumber(-1) errorCondition(recall=StatMedANCOVA, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue)) return() } if (is.element(modelValue, listLMModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) tkdestroy(top) StatMedMultiANOVA() return() } } if (length(data) == 0) { errorCondition(recall=StatMedANCOVA, message=gettextRcmdr("You must select a response variable.")) return() } if (length(group) == 0) { errorCondition(recall=StatMedANCOVA, message=gettextRcmdr("You must select at least one factor.")) return() } if (length(covariate) == 0) { errorCondition(recall=StatMedANCOVA, message=gettextRcmdr("You must select one numeric variable for adjustment.")) return() } closeDialog() if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} # command <- paste("scatterplot(", data, " ~ ", covariate, " | factor(", group, "), reg.line=lm, smooth=FALSE, spread=FALSE, by.groups=TRUE, data=TempDF)", sep="") command <- paste("scatterplot(", data, " ~ ", covariate, " | factor(", group, "), regLine=list(method=lm, lty=1), smooth=FALSE, by.groups=TRUE, data=TempDF)", sep="") # Changted according to the updated car package doItAndPrint(command) # doItAndPrint("library(car)") interaction <- eval(parse(text=paste("signif(Anova(lm(", data, " ~ 1 + factor(", group, ") * ", covariate, ', data=TempDF, na.action=na.omit), type="III")$Pr[4], digits=3)', sep=""))) doItAndPrint(paste('cat(gettextRcmdr("P value for interaction between grouping variable and covariate is"), ', " ", interaction, ', "\n")', sep="")) if(interaction < 0.05){ logger(gettextRcmdr("ANCOVA not performed due to significant interaction between grouping variable and covariate.")) } else { command <- paste(modelValue, " <- lm(", data, " ~ 1 + factor(", group, ") + ", covariate, ", data=TempDF, na.action=na.omit)", sep="") # logger(paste(modelValue, " <- ", command, sep = "")) # assign(modelValue, justDoIt(command), envir = .GlobalEnv) doItAndPrint(paste(modelValue, " <- ", command, sep = "")) doItAndPrint(paste("Anova(", modelValue, ', type="III")', sep="")) if (actmodel==1) activeModel(modelValue) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Anova", model=TRUE, apply="StatMedANCOVA", reset="StatMedANCOVA") tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model: ")), model, sticky="w") tkgrid(modelFrame, sticky="w", columnspan=2) tkgrid(getFrame(dataBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(covariateBox), labelRcmdr(variables2Frame, text=" "), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(optionsFrame, sticky="nw") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Keep results as active model for further analyses")), actmodelCheckBox, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedCorrelation <- function(){ defaults <- list(x=NULL, alternative="two.sided", subset = "") dialog.values <- getDialog("StatMedCorrelation", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Test for Pearson's correlation")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick two)"), listHeight=15, initialSelection=varPosn(dialog.values$x, "numeric")) radioButtons(name="alternative", buttons=c("two.sided", "less", "greater"), values=c("two.sided", "less", "greater"), initialValue=dialog.values$alternative, labels=gettextRcmdr(c("Two-sided", "Correlation < 0", "Correlation > 0")), title=gettextRcmdr("Alternative Hypothesis")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Test for Pearson's correlation"), "#####", sep="")) alternative <- as.character(tclvalue(alternativeVariable)) x <- getSelection(xBox) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedCorrelation", list(x=x, alternative=alternative, subset = tclvalue(subsetVariable))) if (2 > length(x)) { errorCondition(recall=StatMedCorrelation, message=gettextRcmdr("Fewer than 2 variables selected.")) return() } if(2 < length(x)) { errorCondition(recall=StatMedCorrelation, message=gettextRcmdr("More than 2 variables selected.")) return() } closeDialog() .activeDataSet <- ActiveDataSet() if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} # command2 <- paste("scatterplot(", x[1], "~", x[2], # ", reg.line=lm, smooth=FALSE, spread=FALSE, boxplots='xy', span=0.5, data=", .activeDataSet, subset, ")", sep="") command2 <- paste("scatterplot(", x[1], "~", x[2], ", regLine=list(method=lm, lty=1), smooth=FALSE, boxplots='xy', data=", .activeDataSet, subset, ")", sep="") # Changted according to the updated car package doItAndPrint(command2) doItAndPrint("res <- NULL") command <- paste("(res <- cor.test(", subset1, .activeDataSet, subset2, "$", x[1], ", ", subset1, .activeDataSet, subset2, "$", x[2], ', alternative="', alternative, '", method="pearson"))', sep="") doItAndPrint(command) doItAndPrint('cat(gettextRcmdr( "correlation coefficient"), " = ", signif(res$estimate, digits=3), ", ", gettextRcmdr( "95% CI"), " ", signif(res$conf.int[1],digits=3), "-", signif(res$conf.int[2],digits=3), ", ", gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n", sep="")') # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="cor.test", apply="StatMedCorrelation", reset="StatMedCorrelation") tkgrid(labelRcmdr(top, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(xBox), sticky="nw") tkgrid(alternativeFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame,columnspan=2,sticky="w") dialogSuffix(rows=4, columns=1) } StatMedLinearRegression <- function(){ defaults <- list(x=NULL, y=NULL, wald=0, actmodel=0, diagnosis=0, stepwise1=0, stepwise2=0, stepwise3=0, subset = "") dialog.values <- getDialog("StatMedLinearRegression", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Linear regression")) variablesFrame <- tkframe(top) .numeric <- Numeric() xBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Explanatory variables (pick one or more)"), listHeight=15, initialSelection=varPosn(dialog.values$x, "all")) yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Response variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$y, "numeric")) UpdateModelNumber() modelName <- tclVar(paste("RegModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("wald", "actmodel", "diagnosis", "stepwise1", "stepwise2", "stepwise3"), initialValues=c(dialog.values$wald, dialog.values$actmodel, dialog.values$diagnosis, dialog.values$stepwise1, dialog.values$stepwise2, dialog.values$stepwise3),labels=gettextRcmdr(c("Wald test for overall p-value for factors with >2 levels", "Keep results as active model for further analyses", "Show basic diagnostic plots", "Stepwise selection based on AIC", "Stepwise selection based on BIC", "Stepwise selection based on p-value"))) # waldVariable <- tclVar("0") # waldCheckBox <- tkcheckbutton(optionsFrame, variable=waldVariable) # actmodelVariable <- tclVar("0") # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) # stepwise1Variable <- tclVar("0") # stepwise2Variable <- tclVar("0") # stepwise3Variable <- tclVar("0") # stepwise1CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise1Variable) # stepwise2CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise2Variable) # stepwise3CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise3Variable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Linear regression"), "#####", sep="")) x <- getSelection(xBox) y <- getSelection(yBox) closeDialog() wald <- tclvalue(waldVariable) actmodel <- tclvalue(actmodelVariable) diagnosis <- tclvalue(diagnosisVariable) stepwise1 <- tclvalue(stepwise1Variable) stepwise2 <- tclvalue(stepwise2Variable) stepwise3 <- tclvalue(stepwise3Variable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } putDialog("StatMedLinearRegression", list(x=x, y=y, wald=wald, actmodel=actmodel, diagnosis=diagnosis, stepwise1=stepwise1, stepwise2=stepwise2, stepwise3=stepwise3, subset = tclvalue(subsetVariable))) if (0 == length(y)) { UpdateModelNumber(-1) errorCondition(recall=StatMedLinearRegression, message=gettextRcmdr("You must select a response variable.")) return() } if (0 == length(x)) { UpdateModelNumber(-1) errorCondition(recall=StatMedLinearRegression, message=gettextRcmdr("No explanatory variables selected.")) return() } if (is.element(y, x)) { UpdateModelNumber(-1) errorCondition(recall=StatMedLinearRegression, message=gettextRcmdr("Response and explanatory variables must be different.")) return() } Library("aod") modelValue <- trim.blanks(tclvalue(modelName)) if (!is.valid.name(modelValue)){ UpdateModelNumber(-1) errorCondition(recall=StatMedLinearRegression, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue)) return() } if (is.element(modelValue, listLinearModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) linearRegressionModel() return() } } command <- paste("lm(", y, "~", paste(x, collapse="+"), ", data=", ActiveDataSet(), subset, ")", sep="") # logger(paste(modelValue, " <- ", command, sep = "")) # assign(modelValue, justDoIt(command), envir = .GlobalEnv) doItAndPrint(paste(modelValue, " <- ", command, sep = "")) doItAndPrint("res <- NULL") doItAndPrint(paste("(res <- summary(", modelValue, "))", sep="")) if(length(x)>=2){ doItAndPrint(paste("vif(", modelValue, ")", sep="")) logger("###variance inflation factors") } doItAndPrint("multireg.table <- NULL") doItAndPrint(paste("multireg.table <- cbind(res$coefficients[,1], confint(", modelValue, "),res$coefficients[,2:4])", sep="")) doItAndPrint('colnames(multireg.table)[1] <- "Estimate"') doItAndPrint('colnames(multireg.table) <- gettextRcmdr( colnames(multireg.table))') # doItAndPrint("res$coefficients") # doItAndPrint("multireg.table <- res$coefficients") doItAndPrint("multireg.table") # doItAndPrint("remove(res)") if (wald==1) doItAndPrint(paste("waldtest(", modelValue, ")", sep="")) if (diagnosis==1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("oldpar <- par(oma=c(0,0,3,0), mfrow=c(2,2))") doItAndPrint(paste("plot(", modelValue, ")", sep="")) doItAndPrint("par(oldpar)") } if (stepwise1 == 1 | stepwise2 == 1 | stepwise3 == 1){ command <- paste("TempDF <- with(", ActiveDataSet(), ", ", ActiveDataSet(), "[complete.cases(", paste(x, collapse=","), "),])", sep="") doItAndPrint(command) command <- paste("lm(", y, "~", paste(x, collapse="+"), ", data=TempDF", subset, ")", sep="") doItAndPrint(paste(modelValue, " <- ", command, sep="")) } if (stepwise1 == 1){ doItAndPrint("res <- NULL") doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="AIC")', sep="")) doItAndPrint("summary(res)") if (wald==1) doItAndPrint("waldtest(res)") # doItAndPrint("remove(res)") } if (stepwise2 == 1){ doItAndPrint("res <- NULL") doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="BIC")', sep="")) doItAndPrint("summary(res)") if (wald==1) doItAndPrint("waldtest(res)") # doItAndPrint("remove(res)") } if (stepwise3 == 1){ subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" } else{ subset <- paste(", subset='", trim.blanks(subset), "'", sep="") } doItAndPrint(paste('step.p.lm(', modelValue, ', "TempDF", wald=', wald, subset, ")", sep="")) } if (actmodel==1) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="lm", model=TRUE, apply="StatMedLinearRegression", reset="StatMedLinearRegression") tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(yBox), labelRcmdr(variablesFrame, text=" "), getFrame(xBox), sticky="nw") tkgrid(variablesFrame, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Wald test for overall p-value for factors with >2 levels")), waldCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Keep results as active model for further analyses")), actmodelCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on AIC")), stepwise1CheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on BIC")), stepwise2CheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on p-value")), stepwise3CheckBox, sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, stick="w") tkgrid.configure(helpButton, sticky="e") dialogSuffix(rows=4, columns=1) } listLMMs <- function(envir=.GlobalEnv, ...) { objects <- ls(envir=envir, ...) if (length(objects) == 0) NULL else objects[sapply(objects, function(.x) "lmerMod" == (class(get(.x, envir=envir))[1]))] } StatMedLinearMixedModel <- function(){ Library("lme4") defaults <- list(lhs = "", rhs = "", subset = "", actmodel = 0, pvalue = 1, weight = gettextRcmdr("<no variable selected>"), estimType = "reml") dialog.values <- getDialog("StatMedLinearMixedModel", defaults) currentFields$lhs <- dialog.values$lhs #Values in currentFields will be sent to modelFormula currentFields$rhs <- dialog.values$rhs currentFields$subset <- dialog.values$subset initializeDialog(title=gettextRcmdr("Linear Mixed Model")) dialog.values <- getDialog("StateMedLinearMixedModel", defaults) .activeModel <- ActiveModel() currentModel <- if (!is.null(.activeModel)) class(get(.activeModel, envir=.GlobalEnv))[1] == "lmerMod" else FALSE if (currentModel) { currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv)) if (currentFields$data != ActiveDataSet()) currentModel <- FALSE } currentModel <- TRUE if (isTRUE(getRcmdr("reset.model"))) { currentModel <- FALSE putRcmdr("reset.model", FALSE) } UpdateModelNumber() modelName <- tclVar(paste("LMM.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) modelFormula(showBar=TRUE) checkBoxes(frame="checkboxFrame", boxes=c("actmodel", "pvalue"), initialValues=c(dialog.values$actmodel, dialog.values$pvalue),labels=gettextRcmdr(c("Keep results as active model for further analyses", "Show p value"))) radioButtons(name="estimType", buttons=c("reml", "ml"), initialValue=dialog.values$estimType, labels=gettextRcmdr(c("Restricted maximum likelihood (REML)", "Maximum likelihood (ML)")), title=gettextRcmdr("Estimation Criterion")) subsetWeightFrame <- tkframe(top) # subsetBox(window=subsetWeightFrame, model=TRUE) StatMedSubsetBox(window=subsetWeightFrame, model=TRUE) weightComboBox <- variableComboBox(subsetWeightFrame, variableList=Numeric(), initialSelection=dialog.values$weight, title=gettextRcmdr("Weights")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Linear Mixed Model"), "#####", sep="")) modelValue <- trim.blanks(tclvalue(modelName)) closeDialog() if (!is.valid.name(modelValue)){ errorCondition(recall=linearMixedModel, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } actmodel <- tclvalue(actmodelVariable) pvalue <- tclvalue(pvalueVariable) weight.var <- getSelection(weightComboBox) estimType <- tclvalue(estimTypeVariable) putDialog("StatMedLinearMixedModel", list(lhs = tclvalue(lhsVariable), rhs = tclvalue(rhsVariable), subset=tclvalue(subsetVariable), actmodel = actmodel, pvalue = pvalue, weight = weight.var, estimType = estimType)) weights <- if (weight.var == gettextRcmdr("<no variable selected>")) "" else paste(", weights=", weight.var, sep="") check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedLinearMixedModel, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedLinearMixedModel, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE) return() } if (!grepl("\\(.*\\|.*\\)", tclvalue(rhsVariable))) { errorCondition(recall=StatMedLinearMixedModel, message=gettextRcmdr("There are no random effects in the model."), model=TRUE) return() } if (is.element(modelValue, listLMMs())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) StatMedLinearMixedModel() return() } } formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ") reml <- as.character(estimType == "reml") if("package:lmerTest" %in% search()==TRUE) doItAndPrint("detach(package:lmerTest)") #To keep results as active model, originel lmer function should be done command <- paste("lmer(", formula, ", data=", ActiveDataSet(), subset, weights, ", REML=", reml, ")", sep="") doItAndPrint(paste(modelValue, " <- ", command, sep = "")) if(pvalue==0) doItAndPrint(paste("summary(", modelValue, ")", sep="")) if(pvalue==1){ doItAndPrint("library(lmerTest)") doItAndPrint(paste("res <- ", command, sep = "")) doItAndPrint(paste("summary(res)", sep="")) doItAndPrint("detach(package:lmerTest)") } #activeModel(modelValue) if (actmodel==1) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="lmer", model=TRUE, reset="resetLMM", apply="StatMedLinearMixedModel") tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(subsetFrame, tklabel(subsetWeightFrame, text=" "), getFrame(weightComboBox), sticky="nw") tkgrid(checkboxFrame, sticky="w") tkgrid(estimTypeFrame, sticky="w") tkgrid(subsetWeightFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(focus=lhsEntry, preventDoubleClick=TRUE) } StatMedMannW <- function(){ defaults <- list(group=NULL, response=NULL, alternative="two.sided", test="default", subset = "") dialog.values <- getDialog("StatMedMannW", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Mann-Whitney U test")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Grouping variables with two levels (pick at least one)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) optionsFrame <- tkframe(top) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Mann-Whitney U test"), "#####", sep="")) group <- getSelection(groupBox) response <- getSelection(responseBox) alternative <- as.character(tclvalue(alternativeVariable)) test <- as.character(tclvalue(testVariable)) .activeDataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) # subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) "" # else paste(", subset=", subset, sep="") if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset3 <- .activeDataSet subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset3 <- paste("subset(", .activeDataSet, ", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedMannW", list(group=group, response=response, alternative=alternative, test=test, subset = tclvalue(subsetVariable))) if (length(group) == 0) { errorCondition(recall=StatMedMannW, message=gettextRcmdr("You must select a groups variable.")) return() } if (length(response) == 0) { errorCondition(recall=StatMedMannW, message=gettextRcmdr("You must select a response variable.")) return() } closeDialog() nvar = length(group) # doItAndPrint("p.value <- NA") # doItAndPrint("groups <- NA") doItAndPrint("group.names <- NULL") doItAndPrint("group.median <- NULL") doItAndPrint("group.min <- NULL") doItAndPrint("group.max <- NULL") doItAndPrint("group.1Q <- NULL") doItAndPrint("group.3Q <- NULL") doItAndPrint("group.p <- NULL") if(eval(parse(text=paste('"res" %in% objects()')))) doItAndPrint("remove(res)") for (i in 1:nvar) { levels <- eval(parse(text=paste("with(droplevels(", subset3, "), length(levels(as.factor(", group[i], "))))", sep=""))) if(levels!=2){ errorCondition(recall=StatMedMannW, message=gettextRcmdr("You must select a variable with two levels.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- (paste("boxplot(", response, "~ factor(", group[i], '), ylab="', response, '", xlab="', group[i], '"', ", data=", ActiveDataSet(), subset, ")", sep="")) logger(command) justDoIt(command) if (test == "default"){ doItAndPrint(paste("(res <- wilcox.test(", response, " ~ factor(", group[i], '), alternative="', alternative, '", data=', .activeDataSet, subset, "))", sep="")) } else if (test == "BM"){ Library("lawstat") doItAndPrint(paste("(res <- with(droplevels(", subset3, "), brunner.munzel.test(", response, "[", group[i], "==levels(as.factor(", group[i], "))[1]], ", response, "[", group[i], "==levels(as.factor(", group[i], "))[2]])))", sep="")) } else { doItAndPrint(paste("(res <- wilcox.test(", response, " ~ factor(", group[i], "), alternative='", alternative, "', exact=", test=="exact", ", correct=", test=="correct",", data=", .activeDataSet, subset, "))", sep="")) } # doItAndPrint(paste("p.value[", i, "] <- signif(res$p.value, digits=3)", sep="")) # doItAndPrint(paste("groups[", i, '] <- "', group[i], '"', sep="")) group.levels <- eval(parse(text=paste("levels(factor(", subset1, ActiveDataSet(), subset2, "$", group[i], "))", sep=""))) if(length(group.levels)!=2) next for (j in 1:2){ doItAndPrint(paste('group.names <- c(group.names, "', group[i], "=", group.levels[j], '")', sep="")) doItAndPrint(paste("group.min <- c(group.min, with(", subset1, ActiveDataSet(), subset2, ", min(", response, "[", group[i], "=='", group.levels[j], "'], na.rm=TRUE)))", sep="")) doItAndPrint(paste("group.1Q <- c(group.1Q, with(", subset1, ActiveDataSet(), subset2, ", quantile(", response, "[", group[i], "=='", group.levels[j], "'], 0.25, na.rm=TRUE)))", sep="")) doItAndPrint(paste("group.median <- c(group.median, with(", subset1, ActiveDataSet(), subset2, ", median(", response, "[", group[i], "=='", group.levels[j], "'], na.rm=TRUE)))", sep="")) doItAndPrint(paste("group.3Q <- c(group.3Q, with(", subset1, ActiveDataSet(), subset2, ", quantile(", response, "[", group[i], "=='", group.levels[j], "'], 0.75, na.rm=TRUE)))", sep="")) doItAndPrint(paste("group.max <- c(group.max, with(", subset1, ActiveDataSet(), subset2, ", max(", response, "[", group[i], "=='", group.levels[j], "'], na.rm=TRUE)))", sep="")) if (j == 1){ doItAndPrint("group.p <- c(group.p, signif(res$p.value,digits=3))") } else { doItAndPrint('group.p <- c(group.p, "")') } } # doItAndPrint("remove(res)") } # doItAndPrint("mannwhitney.table <- data.frame(p.value=p.value)") # doItAndPrint('colnames(mannwhitney.table) <- gettextRcmdr( colnames(mannwhitney.table))') # doItAndPrint("rownames(mannwhitney.table) <- groups") # doItAndPrint("mannwhitney.table") doItAndPrint("mannwhitney.table <- NULL") doItAndPrint("mannwhitney.table <- data.frame(Minimum=group.min, Q1=group.1Q, Median=group.median, Q3=group.3Q, Maximum=group.max, p.value=group.p)") doItAndPrint("rownames(mannwhitney.table) <- group.names") doItAndPrint('colnames(mannwhitney.table)[c(2,4)] <- c("25%", "75%")') doItAndPrint('colnames(mannwhitney.table) <- gettextRcmdr(colnames(mannwhitney.table))') doItAndPrint("mannwhitney.table") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="wilcox.test", apply="StatMedMannW", reset="StatMedMannW") radioButtons(optionsFrame, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), initialValue=dialog.values$alternative, labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) radioButtons(optionsFrame, name="test", buttons=c("default", "exact", "normal", "correct", "BM"), labels=gettextRcmdr(c("Default", "Exact", "Normal approximation", "Normal approximation with\ncontinuity correction", "Brunner-Munzel test")), initialValue=dialog.values$test, title=gettextRcmdr("Type of Test")) tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(alternativeFrame, labelRcmdr(optionsFrame, text=" "), testFrame, sticky="nw") tkgrid(optionsFrame, sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=4, columns=2) } StatMedWilSign <- function(){ defaults <- list(x=NULL, y=NULL, alternative="two.sided", test="default", subset = "") dialog.values <- getDialog("StatMedWilSign", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Wilcoxon's signed rank test")) .numeric <- Numeric() variablesFrame <- tkframe(top) xBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("First variable (pick one)"), listHeight=12, initialSelection=varPosn(dialog.values$x, "numeric")) yBox <- variableListBox(variablesFrame, .numeric, title=gettextRcmdr("Second variable (pick one)"), listHeight=12, initialSelection=varPosn(dialog.values$y, "numeric")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Wilcoxon's signed rank test"), "#####", sep="")) x <- getSelection(xBox) y <- getSelection(yBox) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } alternative <- as.character(tclvalue(alternativeVariable)) test <- as.character(tclvalue(testVariable)) putDialog("StatMedWilSign", list(x=x, y=y, alternative=alternative, test=test, subset = tclvalue(subsetVariable))) closeDialog() if (length(x) == 0 | length(y) == 0) { errorCondition(recall=StatMedWilSign, message=gettextRcmdr("You must select two variables.")) return() } if (x == y) { errorCondition(recall=StatMedWilSign, message=gettextRcmdr("The two variables must be different.")) return() } .activeDataSet <- ActiveDataSet() doItAndPrint(paste("median(", subset1, .activeDataSet, subset2, "$", x, " - ", subset1, .activeDataSet, subset2, "$", y, ", na.rm=TRUE) # median difference", sep="")) doItAndPrint("res <- NULL") if (test == "default"){ doItAndPrint(paste("(res <- wilcox.test(", subset1, .activeDataSet, subset2, "$", x, ", ", subset1, .activeDataSet, subset2, "$", y, ", alternative='", alternative, "', paired=TRUE))", sep="")) } else if (test == "exact"){ doItAndPrint(paste("(res <- wilcox.test(", subset1, .activeDataSet, subset2, "$", x, ", ", subset1, .activeDataSet, subset2, "$", y, ", alternative='", alternative, "', exact=TRUE, paired=TRUE))", sep="")) } else { doItAndPrint(paste("(res <- wilcox.test(", subset1, .activeDataSet, subset2, "$", x, ", ", subset1, .activeDataSet, subset2, "$", y, ", alternative='", alternative, "', correct=", test=="correct", ", exact=FALSE, paired=TRUE))", sep="")) } command <- paste('cat(gettextRcmdr( "Wilcoxon', "'", 's signed rank test")', ', "', gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), '\n")', sep="") doItAndPrint(command) # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="wilcox.test", apply="StatMedWilSign", reset="StatMedWilSign") radioButtons(name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), initialValue=dialog.values$alternative, labels=gettextRcmdr(c("Two-sided", "Difference < 0", "Difference > 0")), title=gettextRcmdr("Alternative Hypothesis")) radioButtons(name="test", buttons=c("default", "exact", "normal", "correct"), labels=gettextRcmdr(c("Default", "Exact", "Normal approximation", "Normal approximation with\ncontinuity correction")), initialValue=dialog.values$test, title=gettextRcmdr("Type of Test")) tkgrid(getFrame(xBox), labelRcmdr(variablesFrame, text=" "), getFrame(yBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(alternativeFrame, sticky="nw") tkgrid(testFrame, sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=3, columns=2) } StatMedKruWalli <- function(){ defaults <- list(group=NULL, response=NULL, steeldwass=0, steel=0, bonferroni=0, holm=0, subset = "") dialog.values <- getDialog("StatMedKruWalli", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Kruskal-Wallis test")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Groups (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("bonferroni", "holm", "steeldwass", "steel"), initialValues=c(dialog.values$bonferroni, dialog.values$holm, dialog.values$steeldwass, dialog.values$steel),labels=gettextRcmdr(c("Pairwise comparison (Bonferroni)", "Pairwise comparison (Holm)", "Pairwise comparison (Steel-Dwass)", "Pairwise comparison (Steel)"))) # steeldwassVariable <- tclVar("0") # steeldwassCheckBox <- tkcheckbutton(optionsFrame, variable=steeldwassVariable) # steelVariable <- tclVar("0") # steelCheckBox <- tkcheckbutton(optionsFrame, variable=steelVariable) # bonferroniVariable <- tclVar("0") # bonferroniCheckBox <- tkcheckbutton(optionsFrame, variable=bonferroniVariable) # holmVariable <- tclVar("0") # holmCheckBox <- tkcheckbutton(optionsFrame, variable=holmVariable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Kruskal-Wallis test"), "#####", sep="")) group <- getSelection(groupBox) response <- getSelection(responseBox) steeldwass <- tclvalue(steeldwassVariable) steel <- tclvalue(steelVariable) bonferroni <- tclvalue(bonferroniVariable) holm <- tclvalue(holmVariable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedKruWalli", list(group=group, response=response, steeldwass=steeldwass, steel=steel, bonferroni=bonferroni, holm=holm, subset = tclvalue(subsetVariable))) if (length(group) == 0) { errorCondition(recall=StatMedKruWalli, message=gettextRcmdr("You must select a groups variable.")) return() } closeDialog() if (length(response) == 0) { errorCondition(recall=StatMedKruWalli, message=gettextRcmdr("You must select a response variable.")) return() } .activeDataSet <- ActiveDataSet() if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- (paste("boxplot(", response, "~ factor(", group, '), ylab="', response, '", xlab="', group, '"', ", data=", ActiveDataSet(), subset, ")", sep="")) doItAndPrint(command) doItAndPrint(paste("tapply(", paste(subset1, .activeDataSet, subset2, "$", response, sep=""), ", ", paste(subset1, .activeDataSet, subset2, "$", group, sep=""), ", median, na.rm=TRUE)", sep="")) doItAndPrint("res <- NULL") doItAndPrint(paste("(res <- kruskal.test(", response, " ~ factor(", group, "), data=", .activeDataSet, subset, "))", sep="")) doItAndPrint('cat(gettextRcmdr( "Kruskal-Wallis test"), " ", gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n", sep="")') # doItAndPrint("remove(res)") if (bonferroni==1){ doItAndPrint(paste("pairwise.kruskal.test(", subset1, .activeDataSet, subset2, "$", response, ", ", subset1, .activeDataSet, subset2, "$", group, ', data.name="', .activeDataSet, '", p.adjust.method="bonferroni")', sep="")) } if (holm==1){ doItAndPrint(paste("pairwise.kruskal.test(", subset1, .activeDataSet, subset2, "$", response, ", ", subset1, .activeDataSet, subset2, "$", group, ', data.name="', .activeDataSet, '", p.adjust.method="holm")', sep="")) } if (steeldwass==1){ command <- paste("Steel.Dwass(", subset1, .activeDataSet, subset2, "$", response, ", ", subset1, .activeDataSet, subset2, "$", group, ")", sep="") doItAndPrint(command) } if (steel==1){ Library("mvtnorm") command <- paste("Steel(", subset1, .activeDataSet, subset2, "$", response, ", ", subset1, .activeDataSet, subset2, "$", group, ")", sep="") doItAndPrint(command) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="kruskal.test", apply="StatMedKruWalli", reset="StatMedKruWalli") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("Pairwise comparison"), fg="blue"), sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Bonferroni)")), bonferroniCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Holm)")), holmCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Steel-Dwass)")), steeldwassCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Steel)")), steelCheckBox, sticky="w") tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("The first group in alphabetical will be treated as the reference group."), fg="blue"), sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=2, columns=2) } StatMedFriedman <- function(){ defaults <- list(response=NULL, bonferroni=0, holm=0, subset = "") dialog.values <- getDialog("StatMedFriedman", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Friedman test")) responseBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Repeated-Measures Variables (pick two or more)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("bonferroni", "holm"), initialValues=c(dialog.values$bonferroni, dialog.values$holm),labels=gettextRcmdr(c("Pairwise comparison (Bonferroni)", "Pairwise comparison (Holm)"))) # bonferroniVariable <- tclVar("0") # bonferroniCheckBox <- tkcheckbutton(optionsFrame, variable=bonferroniVariable) # holmVariable <- tclVar("0") # holmCheckBox <- tkcheckbutton(optionsFrame, variable=holmVariable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Friedman test"), "#####", sep="")) responses <- getSelection(responseBox) bonferroni <- tclvalue(bonferroniVariable) holm <- tclvalue(holmVariable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } putDialog("StatMedFriedman", list(response=responses, bonferroni=bonferroni, holm=holm, subset = tclvalue(subsetVariable))) closeDialog() if (length(responses) < 2) { errorCondition(recall=StatMedFriedman, message=gettextRcmdr("You must select at least two variables.")) return() } .activeDataSet <- ActiveDataSet() command <- paste('na.omit(with(', subset1, .activeDataSet, subset2, ', cbind(', paste(responses, collapse=", "), ')))', sep="") # logger(paste(".Responses <- ", command, sep="")) # assign(".Responses", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(".Responses <- ", command, sep="")) doItAndPrint("apply(.Responses, 2, median)") doItAndPrint("res <- NULL") doItAndPrint("(res <- friedman.test(.Responses))") doItAndPrint('cat(gettextRcmdr( "Friedman test"), " ", gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n", sep="")') # doItAndPrint("remove(res)") if (bonferroni==1){ doItAndPrint(paste('pairwise.friedman.test(.Responses, "', .activeDataSet, '", p.adjust.method="bonferroni")', sep="")) } if (holm==1){ doItAndPrint(paste('pairwise.friedman.test(.Responses, "', .activeDataSet, '", p.adjust.method="holm")', sep="")) } logger("remove(.Responses)") remove(.Responses, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="friedman.test", apply="StatMedFriedman", reset="StatMedFriedman") tkgrid(getFrame(responseBox), sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("Pairwise comparison"), fg="blue"), sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Bonferroni)")), bonferroniCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Holm)")), holmCheckBox, sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } StatMedJT <- function(){ Library("clinfun") defaults <- list(response=NULL, group=NULL, alternative="two.sided", subset = "") dialog.values <- getDialog("StatMedJT", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Jonckheere-Terpstra test")) variablesFrame <- tkframe(top) .factors <- Variables() responseBox <- variableListBox(variablesFrame, Numeric(), title=gettextRcmdr("Response Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "numeric")) groupBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Grouping variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Jonckheere-Terpstra test"), "#####", sep="")) response <- getSelection(responseBox) group <- getSelection(groupBox) alternative <- as.character(tclvalue(alternativeVariable)) .activeDataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { .subDataSet <- .activeDataSet } else { .subDataSet <- paste("subset(", .activeDataSet, ", ", subset, ")", sep="") } putDialog("StatMedJT", list(response=response, group=group, alternative=alternative, subset = tclvalue(subsetVariable))) closeDialog() if (length(response) == 0 || length(group) == 0){ errorCondition(recall=StatMedJT, message=gettextRcmdr("You must select two variables.")) return() } if (response == group) { errorCondition(recall=StatMedJT, message=gettextRcmdr("Objective variable and grouping variable must be different.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- (paste("boxplot(", response, "~ factor(", group, '), ylab="', response, '", xlab="', group, '"', ", data=", .subDataSet, ")", sep="")) logger(command) justDoIt(command) doItAndPrint("res <- NULL") command <- paste("(res <- jonckheere.test(", .subDataSet, "$", response, ", as.ordered(", .subDataSet, "$", group, '), alternative="', alternative, '"))', sep="") doItAndPrint(command) doItAndPrint('cat(gettextRcmdr( "Jonckheere-Terpstra test"), " ", gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n", sep="")') # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="jonckheere.test", apply="StatMedJT", reset="StatMedJT") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Trend will be evaluated among groups in alphabetical order."), fg="blue"), sticky="w") optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="alternative", buttons=c("two", "inc", "dec"), values=c("two.sided", "increasing", "decreasing"), initialValue=dialog.values$alternative, labels=gettextRcmdr(c("Two-sided", "Increasing tendency", "Decreasing tendency")), title=gettextRcmdr("Alternative Hypothesis")) tkgrid(alternativeFrame, labelRcmdr(optionsFrame, text=" "), sticky="nw") tkgrid(optionsFrame, sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedOrdinalRegressionModel <- function(){ Library("MASS") Library("brant") defaults <- list(lhs = "", rhs = "", initial.type = "logistic", actmodel = 0, subset = "") dialog.values <- getDialog("StatMedOrdinalRegressionModel", defaults) currentFields$lhs <- dialog.values$lhs #Values in currentFields will be sent to modelFormula currentFields$rhs <- dialog.values$rhs currentFields$subset <- dialog.values$subset initializeDialog(title=gettextRcmdr("Ordinal logistic regression")) # defaults <- list(initial.type="logistic") # dialog.values <- getDialog("StatMedOrdinalRegressionModel", defaults) .activeModel <- ActiveModel() .activeDataSet <- ActiveDataSet() checkBoxes(frame="checkboxFrame", boxes=c("actmodel"), initialValues=c(dialog.values$actmodel), labels=gettextRcmdr(c("Keep results as active model for further analyses"))) currentModel <- if (!is.null(.activeModel)) class(get(.activeModel, envir=.GlobalEnv))[1] == "polr" else FALSE # if (currentModel) { # currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv)) # if (currentFields$data != .activeDataSet) currentModel <- FALSE # } # if (isTRUE(getRcmdr("reset.model"))) { # currentModel <- FALSE # putRcmdr("reset.model", FALSE) # } currentModel <- TRUE ###Required to enable currentFields setting UpdateModelNumber() modelName <- tclVar(paste("OrdRegModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) radioButtons(name="modelType", buttons=c("logistic", "probit"), initialValue=dialog.values$initial.type, labels=gettextRcmdr(c("Proportional-odds logit", "Ordered probit")), title=gettextRcmdr("Type of Model")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Ordinal logistic regression"), "#####", sep="")) modelValue <- trim.blanks(tclvalue(modelName)) actmodel <- tclvalue(actmodelVariable) putDialog("StatMedOrdinalRegressionModel", list(lhs = tclvalue(lhsVariable), rhs = tclvalue(rhsVariable), initial.type = tclvalue(modelTypeVariable), actmodel = actmodel, subset=tclvalue(subsetVariable))) closeDialog() if (!is.valid.name(modelValue)){ errorCondition(recall=StatMedOrdinalRegressionModel, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedOrdinalRegressionModel, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedOrdinalRegressionModel, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE) return() } # if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=get(.activeDataSet, envir=.GlobalEnv)))){ # errorCondition(recall=StatMedOrdinalRegressionModel, message=gettextRcmdr("Response variable must be a factor")) # return() # } if (is.element(modelValue, listProportionalOddsModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) StatMedOrdinalRegressionModel() return() } } # putDialog("StatMedOrdinalRegressionModel", list(initial.type = tclvalue(modelTypeVariable))) formula <- paste("as.factor(", tclvalue(lhsVariable), ") ~ ", tclvalue(rhsVariable), sep="") command <- paste("polr(", formula, ', method="', tclvalue(modelTypeVariable), '", data=', .activeDataSet, subset, ", Hess=TRUE)", sep="") doItAndPrint(paste(modelValue, " <- ", command, sep = "")) doItAndPrint(paste("(res <- summary(", modelValue, "))", sep="")) nvar <- eval(parse(text=paste("length((coef(", modelValue, ")))", sep=""))) if(nvar==1){ logger(gettextRcmdr("###Test for proportional odds assumption and VIF calculation")) logger(gettextRcmdr("###requires at least two independent variables.")) } else { doItAndPrint(paste("brant(", modelValue, ")", sep="")) doItAndPrint(paste("vif(", modelValue, ")", sep="")) logger("###variance inflation factors") } #p value calculation from https://stats.idre.ucla.edu/r/dae/ordinal-logistic-regression/ doItAndPrint("odds <- NULL") if (nvar==1){ doItAndPrint(paste("odds <- c(exp(coef(", modelValue, ")), exp(confint(", modelValue, ")))", sep="")) doItAndPrint('odds <- c(odds, pnorm(abs(coef(res)[, "t value"])[1], lower.tail=FALSE)*2)') doItAndPrint("odds <- signif(odds, digits=3)") doItAndPrint('names(odds) <- gettextRcmdr(c("odds ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } else { doItAndPrint(paste("odds <- data.frame(cbind(exp(coef(", modelValue, "))), exp(confint(", modelValue, ")))", sep="")) doItAndPrint(paste('odds <- cbind(odds, pnorm(abs(coef(res)[, "t value"])[1:length(coef(', modelValue,'))], lower.tail=FALSE)*2)', sep="")) doItAndPrint("odds <- signif(odds, digits=3)") doItAndPrint('names(odds) <- gettextRcmdr(c("odds ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } doItAndPrint("odds") if (actmodel==1) activeModel(modelValue) # activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="polr", model=TRUE, reset = "resetPOLR", apply = "StatMedOrdinalRegressionModel") tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") modelFormula() StatMedSubsetBox(model=TRUE) # subsetBox(model=TRUE) tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(checkboxFrame, sticky="w") tkgrid(modelTypeFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(focus=lhsEntry, preventDoubleClick=TRUE) } StatMedMultinomialLogitModel <- function(){ Library("nnet") defaults <- list(lhs = "", rhs = "", actmodel = 0, subset = "") dialog.values <- getDialog("StatMedMultinomialLogitModel", defaults) currentFields$lhs <- dialog.values$lhs #Values in currentFields will be sent to modelFormula currentFields$rhs <- dialog.values$rhs currentFields$subset <- dialog.values$subset initializeDialog(title=gettextRcmdr("Multinomial Logit Model")) .activeModel <- ActiveModel() .activeDataSet <- ActiveDataSet() checkBoxes(frame="checkboxFrame", boxes=c("actmodel"), initialValues=c(dialog.values$actmodel), labels=gettextRcmdr(c("Keep results as active model for further analyses"))) currentModel <- if (!is.null(.activeModel)) class(get(.activeModel, envir=.GlobalEnv))[1] == "multinom" else FALSE # if (currentModel) { # currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv)) # if (currentFields$data != .activeDataSet) currentModel <- FALSE # } # if (isTRUE(getRcmdr("reset.model"))) { # currentModel <- FALSE # putRcmdr("reset.model", FALSE) # } currentModel <- TRUE ###Required to enable currentFields setting UpdateModelNumber() modelName <- tclVar(paste("MLM.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) onOK <- function(){ logger(paste("#####", gettextRcmdr("Multinomial logistic regression"), "#####", sep="")) modelValue <- trim.blanks(tclvalue(modelName)) actmodel <- tclvalue(actmodelVariable) putDialog("StatMedMultinomialLogitModel", list(lhs = tclvalue(lhsVariable), rhs = tclvalue(rhsVariable), actmodel = actmodel, subset=tclvalue(subsetVariable))) closeDialog() if (!is.valid.name(modelValue)){ errorCondition(recall=StatMedMultinomialLogitModel, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedMultinomialLogitModel, message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedMultinomialLogitModel, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE) return() } # if (!is.factor(eval(parse(text=tclvalue(lhsVariable)), envir=get(.activeDataSet, envir=.GlobalEnv)))){ # errorCondition(recall=StatMedMultinomialLogitModel, message=gettextRcmdr("Response variable must be a factor")) # return() # } if (is.element(modelValue, listMultinomialLogitModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) StatMedMultinomialLogitModel() return() } } formula <- paste("as.factor(", tclvalue(lhsVariable), ") ~ ", tclvalue(rhsVariable), sep="") command <- paste("multinom(", formula, ", data=", .activeDataSet, subset, ", trace=FALSE)", sep="") doItAndPrint(paste(modelValue, " <- ", command, sep = "")) doItAndPrint(paste("(res <- summary(", modelValue, ", cor=FALSE, Wald=TRUE))", sep="")) doItAndPrint(paste("signif(exp(coef(", modelValue, ")), digits=3)", sep="")) doItAndPrint(paste("signif(exp(confint(", modelValue, ")), digits=3)", sep="")) doItAndPrint(paste("z <- coef(", modelValue, ")/res$standard.errors", sep="")) doItAndPrint("p.values <- signif((1 - pnorm(abs(z), 0, 1)) * 2, digits=3)") doItAndPrint("p.values") if (actmodel==1) activeModel(modelValue) # activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="multinom", model=TRUE, reset="resetMNL", apply="StatMedMultinomialLogitModel") tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") modelFormula() StatMedSubsetBox(model=TRUE) # subsetBox(model=TRUE) tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(checkboxFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(focus=lhsEntry, preventDoubleClick=TRUE) } StatMedSpearman <- function(){ defaults <- list(x=NULL, alternative="two.sided", method="spearman", subset = "") dialog.values <- getDialog("StatMedSpearman", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Spearman's rank correlation test")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick two)"), listHeight=15, initialSelection=varPosn(dialog.values$x, "numeric")) optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="alternative", buttons=c("two.sided", "less", "greater"), values=c("two.sided", "less", "greater"), initialValue=dialog.values$alternative, labels=gettextRcmdr(c("Two-sided", "Correlation < 0", "Correlation > 0")), title=gettextRcmdr("Alternative Hypothesis")) radioButtons(optionsFrame, name="method", buttons=c("Spearman", "Kendall"), values=c("spearman", "kendall"), initialValue=dialog.values$method, labels=gettextRcmdr(c("Spearman", "Kendall")), title=gettextRcmdr("Method")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Spearman's rank correlation test"), "#####", sep="")) alternative <- as.character(tclvalue(alternativeVariable)) method <- as.character(tclvalue(methodVariable)) x <- getSelection(xBox) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedSpearman", list(x=x, alternative=alternative, method=method, subset = tclvalue(subsetVariable))) if (2 > length(x)) { errorCondition(recall=StatMedSpearman, message=gettextRcmdr("Fewer than 2 variables selected.")) return() } if(2 < length(x)) { errorCondition(recall=StatMedSpearman, message=gettextRcmdr("More than 2 variables selected.")) return() } closeDialog() .activeDataSet <- ActiveDataSet() if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} # command2 <- paste("scatterplot(", x[1], "~", x[2], # ", reg.line=lm, smooth=FALSE, spread=FALSE, boxplots='xy', span=0.5, data=", .activeDataSet, subset, ")", sep="") command2 <- paste("scatterplot(", x[1], "~", x[2], ", regLine=list(method=lm, lty=1), smooth=FALSE, boxplots='xy', data=", .activeDataSet, subset, ")", sep="") # Changted according to the updated car package doItAndPrint(command2) doItAndPrint("res <- NULL") command <- paste("(res <- cor.test(", subset1, .activeDataSet, subset2, "$", x[1], ", ", subset1, .activeDataSet, subset2, "$", x[2], ', alternative="', alternative, '", method="', method, '"))', sep="") doItAndPrint(command) command <- paste('cat(gettextRcmdr( "Spearman', "'", 's rank correlation coefficient")', ', signif(res$estimate, digits=3), gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n")', sep="") doItAndPrint(command) # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="cor.test", apply="StatMedSpearman", reset="StatMedSpearman") tkgrid(labelRcmdr(top, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(xBox), sticky="nw") tkgrid(alternativeFrame, labelRcmdr(optionsFrame, text=" "), methodFrame, sticky="nw") tkgrid(optionsFrame, sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame,columnspan=2,sticky="w") dialogSuffix(rows=4, columns=1) } StatMedFrequency <- function(){ initializeDialog(title=gettextRcmdr("Frequency Distributions")) xBox <- variableListBox(top, Variables(), selectmode="multiple", title=gettextRcmdr("Variables (pick one or more)"), listHeight=15) optionsFrame <- tkframe(top) goodnessOfFitVariable <- tclVar("0") goodnessOfFitCheckBox <- tkcheckbutton(optionsFrame, variable=goodnessOfFitVariable) options2Frame <- tkframe(top) shownaVariable <- tclVar("1") shownaCheckBox <- tkcheckbutton(options2Frame, variable=shownaVariable) options3Frame <- tkframe(top) percentVariable <- tclVar("0") percentCheckBox <- tkcheckbutton(options3Frame, variable=percentVariable) options4Frame <- tkframe(top) graphVariable <- tclVar("0") graphCheckBox <- tkcheckbutton(options4Frame, variable=graphVariable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Frequency Distributions"), "#####", sep="")) x <- getSelection(xBox) if (length(x) == 0){ errorCondition(recall=StatMedFrequency, message=gettextRcmdr("You must select a variable.")) return() } goodnessOfFit <- tclvalue(goodnessOfFitVariable) if (length(x) > 1 && goodnessOfFit == "1"){ errorCondition(recall=StatMedFrequency, message=gettextRcmdr("Goodness-of-fit test not available when more than one variable is selected.")) return() } showna <- tclvalue(shownaVariable) if (showna == 0){ showna <- "" } else { showna <- ", exclude=NULL" } percent <- tclvalue(percentVariable) graph <- tclvalue(graphVariable) closeDialog() .activeDataSet <- ActiveDataSet() for (variable in x){ command <- paste("table(", .activeDataSet, "$", variable, showna, ")", sep="") doItAndPrint(".Table <- NULL") doItAndPrint(paste("(.Table <- ", command, gettextRcmdr(") # counts for "), variable, sep="")) # assign(".Table", justDoIt(command), envir=.GlobalEnv) # doItAndPrint(paste(".Table # counts for", variable)) if (percent==1) doItAndPrint(paste("round(100*.Table/sum(.Table), 2) # percentages for", " ", variable)) if (graph==1) { if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste('barplot(.Table, xlab="', variable, '", ylab="Frequency", axis.lty=1)', sep="") doItAndPrint(command) } } env <- environment() if (goodnessOfFit == 1){ initializeDialog(subwin, title=gettextRcmdr("Goodness-of-Fit Test")) hypothesisFrame <- tkframe(subwin) levs <- eval(parse(text=paste("levels(", .activeDataSet, "$", x, ")", sep=""))) n.levs <- length(levs) assign(".entry.1", tclVar(paste("1/", n.levs, sep="")), envir=env) make.entries <- "labelRcmdr(hypothesisFrame, text='Hypothesized probabilities: ')" make.lev.names <- "labelRcmdr(hypothesisFrame, text='Factor levels:')" for (i in 1:n.levs) { entry.varname <- paste(".entry.", i, sep="") assign(entry.varname, tclVar(paste("1/", n.levs, sep="")), envir=env) make.entries <- paste(make.entries, ", ", "ttkentry(hypothesisFrame, width='5', textvariable=", entry.varname, ")", sep="") make.lev.names <- paste(make.lev.names, ", labelRcmdr(hypothesisFrame, text='", levs[i], "')", sep="") } eval(parse(text=paste("tkgrid(", make.lev.names, ", sticky='w')", sep="")), envir=env) eval(parse(text=paste("tkgrid(", make.entries, ", stick='w')", sep="")), envir=env) tkgrid(hypothesisFrame, sticky="w") onOKsub <- function(){ probs <- rep(NA, n.levs) for (i in 1:n.levs){ entry.varname <- paste(".entry.", i, sep="") res <- try( entry <- eval(parse(text=eval(parse(text=paste("tclvalue(", entry.varname,")", sep="")), envir=env))), silent=TRUE) if (class(res) == "try-error"){ errorCondition(subwin, message=gettextRcmdr("Invalid entry.")) return() } if (length(entry) == 0){ errorCondition(subwin, message=gettextRcmdr("Missing entry.")) return() } opts <- options(warn=-1) probs[i] <- as.numeric(entry) options(opts) } probs <- na.omit(probs) if (length(probs) != n.levs){ errorCondition(subwin, message=sprintf(gettextRcmdr("Number of valid entries (%d)\nnot equal to number levels (%d)."), length(probs), n.levs)) return() } if (any(probs < 0)){ errorCondition(subwin, message=gettextRcmdr("Negative probabilities not allowed.")) return() } if (abs(sum(probs) - 1) > 0.001){ Message(message=gettextRcmdr("Probabilities rescaled to sum to 1."), type="warning") probs <- probs/sum(probs) } closeDialog(subwin) command <- paste("c(", paste(probs, collapse=","), ")", sep="") # logger(paste(".Probs <-", command)) # assign(".Probs", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(".Probs <-", command)) doItAndPrint("chisq.test(.Table, p=.Probs)") logger("remove(.Probs)") remove(.Probs, envir=.GlobalEnv) } subOKCancelHelp(subwin) tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subwin, rows=2, columns=1, onOK=onOKsub, focus=subwin) } # logger("remove(.Table)") # remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="table") tkgrid(labelRcmdr(top, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(xBox), sticky="nw") tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Chi-square goodness-of-fit test (for one variable only)")), goodnessOfFitCheckBox, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(labelRcmdr(options2Frame, text=gettextRcmdr("Show missing data")), shownaCheckBox, sticky="w") tkgrid(options2Frame, sticky="w") tkgrid(labelRcmdr(options3Frame, text=gettextRcmdr("Show percent")), percentCheckBox, sticky="w") tkgrid(options3Frame, sticky="w") tkgrid(labelRcmdr(options4Frame, text=gettextRcmdr("Show graph")), graphCheckBox, sticky="w") tkgrid(options4Frame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=2) } StatMedProbCI <- function(){ initializeDialog(title=gettextRcmdr("Confidence interval for a proportion")) variableFrame <- tkframe(top) sample <- tclVar("") sampleEntry <- ttkentry(variableFrame, width="20", textvariable=sample) event <- tclVar("") eventEntry <- ttkentry(variableFrame, width="20", textvariable=event) CI <- tclVar("95") CIEntry <- ttkentry(variableFrame, width="20", textvariable=CI) onOK <- function(){ logger(paste("#####", gettextRcmdr("Confidence interval for a proportion"), "#####", sep="")) sample <- tclvalue(sample) event <- tclvalue(event) CI <- tclvalue(CI) closeDialog() if (length(sample) == 0 || length(event) == 0){ errorCondition(recall=StatMedProbCI, message=gettextRcmdr("You must select a variable.")) return() } doItAndPrint(paste("prop.conf(", event, ", ", sample, ", ", CI, ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(variableFrame, text=gettextRcmdr("Total number of samples")), sampleEntry, sticky="w") tkgrid.configure(sampleEntry, sticky="w") tkgrid(tklabel(variableFrame, text=gettextRcmdr("Number of events")), eventEntry, sticky="w") tkgrid.configure(eventEntry, sticky="w") tkgrid(tklabel(variableFrame, text=gettextRcmdr("Confidence interval")), CIEntry, sticky="w") tkgrid.configure(CIEntry, sticky="w") tkgrid(variableFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedProbSingle <- function(){ defaults <- list(x=NULL, chisq=0, exact=1, continuity="TRUE", alternative="two.sided", p0="0.5", confidence="0.95", subset="") dialog.values <- getDialog("StatMedProbSingle", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("One sample proportion test")) xBox <- variableListBox(top, Variables(), title=gettextRcmdr("Binary variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$x, "all")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("One sample proportion test"), "#####", sep="")) x <- getSelection(xBox) chisq <- tclvalue(chisqTestVariable) exact <- tclvalue(exactTestVariable) continuity <- tclvalue(continuityVariable) alternative <- as.character(tclvalue(alternativeVariable)) level <- tclvalue(confidenceVariable) p0 <- tclvalue(p0Variable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } putDialog("StatMedProbSingle", list(x=x, chisq=chisq, exact=exact, continuity=continuity, alternative=alternative, p0=p0, confidence=level, subset=tclvalue(subsetVariable))) if (length(x) == 0){ errorCondition(recall=StatMedProbSingle, message=gettextRcmdr("You must select a variable.")) return() } closeDialog() doItAndPrint(".Table <- NULL") doItAndPrint(paste("(.Table <- table(", subset1, ActiveDataSet(), subset2, "$", x, "))", sep="")) if (as.character(eval(parse(text=paste("length(.Table)"))))=="1"){ n <- as.character(eval(parse(text=paste(".Table")))) if (eval(parse(text=paste("dimnames(.Table)")))=="1"){ m <- n } else{ m <- "0" } if(chisq==1){ doItAndPrint("res <- NULL") command <- paste("(res <- prop.test(", m, ", ", n, ", p=", p0, ', alternative="', alternative, '", conf.level=', level, ", correct=", continuity, "))", sep="") doItAndPrint(command) } if(exact==1){ doItAndPrint("res <- NULL") command <- paste("(res <- binom.test(", m, ", ", n, ", p=", p0, ', alternative="', alternative, '", conf.level=', level, "))", sep="") doItAndPrint(command) } } else { if(chisq==1){ doItAndPrint("res <- NULL") command <- paste("(res <- prop.test(.Table[2], .Table[1]+ .Table[2], p=", p0, ', alternative="', alternative, '", conf.level=', level, ", correct=", continuity, "))", sep="") doItAndPrint(command) } if(exact==1){ doItAndPrint("res <- NULL") command <- paste("(res <- binom.test(.Table[2], .Table[1]+ .Table[2], p=", p0, ', alternative="', alternative, '", conf.level=', level, "))", sep="") doItAndPrint(command) } } doItAndPrint('cat(gettextRcmdr( "Single-Sample Proportion Test"), " ", gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n", sep="")') # doItAndPrint("remove(res)") # doItAndPrint("remove(.Table)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="binom.test", apply="StatMedProbSingle", reset="StatMedProbSingle") radioButtons(top, name="alternative", buttons=c("twosided", "less", "greater"), values=c("two.sided", "less", "greater"), initialValue=dialog.values$alternative, labels=gettextRcmdr(c("Population proportion p!=p0", "Population proportion p<p0", "Population proportion p>p0")), title=gettextRcmdr("Alternative Hypothesis")) rightFrame <- tkframe(top) confidenceFrame <- tkframe(rightFrame) confidenceVariable <- tclVar(dialog.values$confidence) confidenceField <- ttkentry(confidenceFrame, width="6", textvariable=confidenceVariable) p0Frame <- tkframe(rightFrame) p0Variable <- tclVar(dialog.values$p0) p0Field <- ttkentry(p0Frame, width="6", textvariable=p0Variable) tkgrid(getFrame(xBox), sticky="nw") analysisFrame <- tkframe(top) checkBoxes(window=analysisFrame, frame="testsFrame", boxes=c("chisqTest", "exactTest"), initialValues=c(dialog.values$chisq, dialog.values$exact), labels=gettextRcmdr(c("Chi-square test", "Exact test"))) radioButtons(analysisFrame, name="continuity", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue=dialog.values$continuity, labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Continuity correction of chi-square test")) tkgrid(testsFrame, labelRcmdr(analysisFrame, text=" "), continuityFrame, sticky="w") tkgrid(analysisFrame, sticky="w") tkgrid(labelRcmdr(rightFrame, text=""), sticky="w") tkgrid(labelRcmdr(p0Frame, text=gettextRcmdr("Null hypothesis: p=p0: p0 =")), p0Field, sticky="w") tkgrid(p0Frame, sticky="w") tkgrid(labelRcmdr(confidenceFrame, text=gettextRcmdr("Confidence Level: ")), confidenceField, sticky="w") tkgrid(confidenceFrame, sticky="w") tkgrid(alternativeFrame, sticky="nw") tkgrid(rightFrame, sticky="nw") tkgrid.configure(confidenceField, sticky="e") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=4, columns=2) } StatMedProbDiffCI <- function(){ initializeDialog(title=gettextRcmdr("Confidence interval for a difference between two proportions")) variableFrame <- tkframe(top) sample1 <- tclVar("") sample1Entry <- ttkentry(variableFrame, width="20", textvariable=sample1) event1 <- tclVar("") event1Entry <- ttkentry(variableFrame, width="20", textvariable=event1) variable2Frame <- tkframe(top) sample2 <- tclVar("") sample2Entry <- ttkentry(variable2Frame, width="20", textvariable=sample2) event2 <- tclVar("") event2Entry <- ttkentry(variable2Frame, width="20", textvariable=event2) CI <- tclVar("95") CIEntry <- ttkentry(variable2Frame, width="20", textvariable=CI) onOK <- function(){ logger(paste("#####", gettextRcmdr("Confidence interval for a difference between two proportions"), "#####", sep="")) sample1 <- tclvalue(sample1) event1 <- tclvalue(event1) sample2 <- tclvalue(sample2) event2 <- tclvalue(event2) CI <- tclvalue(CI) closeDialog() if (length(sample1) == 0 || length(event1) == 0 || length(sample2) == 0 || length(event2) == 0){ errorCondition(recall=StatMedProbDiffCI, message=gettextRcmdr("You must select a variable.")) return() } doItAndPrint(paste("prop.diff.conf(", event1, ", ", sample1, ", ", event2, ", ", sample2, ", ", CI, ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(variableFrame, text=gettextRcmdr("Number of samples in group 1")), sample1Entry, sticky="w") tkgrid.configure(sample1Entry, sticky="w") tkgrid(tklabel(variableFrame, text=gettextRcmdr("Number of events in group 1")), event1Entry, sticky="w") tkgrid.configure(event1Entry, sticky="w") tkgrid(tklabel(variable2Frame, text=gettextRcmdr("Number of samples in group 2")), sample2Entry, sticky="w") tkgrid.configure(sample2Entry, sticky="w") tkgrid(tklabel(variable2Frame, text=gettextRcmdr("Number of events in group 2")), event2Entry, sticky="w") tkgrid.configure(event2Entry, sticky="w") tkgrid(tklabel(variable2Frame, text=gettextRcmdr("Confidence interval")), CIEntry, sticky="w") tkgrid.configure(CIEntry, sticky="w") tkgrid(variableFrame, sticky="nw") tkgrid(variable2Frame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedProbRatioCI <- function(){ initializeDialog(title=gettextRcmdr("Confidence interval for a ratio of two proportions")) variableFrame <- tkframe(top) sample1 <- tclVar("") sample1Entry <- ttkentry(variableFrame, width="20", textvariable=sample1) event1 <- tclVar("") event1Entry <- ttkentry(variableFrame, width="20", textvariable=event1) variable2Frame <- tkframe(top) sample2 <- tclVar("") sample2Entry <- ttkentry(variable2Frame, width="20", textvariable=sample2) event2 <- tclVar("") event2Entry <- ttkentry(variable2Frame, width="20", textvariable=event2) CI <- tclVar("95") CIEntry <- ttkentry(variable2Frame, width="20", textvariable=CI) onOK <- function(){ logger(paste("#####", gettextRcmdr("Confidence interval for a ratio of two proportions"), "#####", sep="")) sample1 <- tclvalue(sample1) event1 <- tclvalue(event1) sample2 <- tclvalue(sample2) event2 <- tclvalue(event2) CI <- tclvalue(CI) closeDialog() if (length(sample1) == 0 || length(event1) == 0 || length(sample2) == 0 || length(event2) == 0){ errorCondition(recall=StatMedProbRatioCI, message=gettextRcmdr("You must select a variable.")) return() } doItAndPrint(paste("prop.ratio.conf(", event1, ", ", sample1, ", ", event2, ", ", sample2, ", ", CI, ")", sep="")) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(variableFrame, text=gettextRcmdr("Number of samples in group 1")), sample1Entry, sticky="w") tkgrid.configure(sample1Entry, sticky="w") tkgrid(tklabel(variableFrame, text=gettextRcmdr("Number of events in group 1")), event1Entry, sticky="w") tkgrid.configure(event1Entry, sticky="w") tkgrid(tklabel(variable2Frame, text=gettextRcmdr("Number of samples in group 2")), sample2Entry, sticky="w") tkgrid.configure(sample2Entry, sticky="w") tkgrid(tklabel(variable2Frame, text=gettextRcmdr("Number of events in group 2")), event2Entry, sticky="w") tkgrid.configure(event2Entry, sticky="w") tkgrid(tklabel(variable2Frame, text=gettextRcmdr("Confidence interval")), CIEntry, sticky="w") tkgrid.configure(CIEntry, sticky="w") tkgrid(variableFrame, sticky="nw") tkgrid(variable2Frame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedBarGraph <- function(){ defaults <- list(variable=NULL, group=NULL, group2=NULL, color=0, beside=0, percent=0, subset="") dialog.values <- getDialog("StatMedBarGraph", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Bar graph(Frequencies)")) variablesFrame <- tkframe(top) variableBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$variable, "all")) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable1(pick 0 or 1)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) group2Box <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable2(pick 0 or 1)"), listHeight=15, initialSelection=varPosn(dialog.values$group2, "all")) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("color", "beside", "percent"), initialValues=c(dialog.values$color, dialog.values$beside, dialog.values$percent),labels=gettextRcmdr(c("Draw in color", "Show groups side by side", "Compare proportion in each group"))) # checkBoxes(frame="color", boxes=c("color"),initialValues=c(0),labels=gettextRcmdr(c("Draw in color"))) # checkBoxes(frame="beside", boxes=c("beside"),initialValues=c(0),labels=gettextRcmdr(c("Show groups side by side"))) # checkBoxes(frame="percent", boxes=c("percent"),initialValues=c(0),labels=gettextRcmdr(c("Compare proportion in each group"))) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Bar graph(Frequencies)"), "#####", sep="")) variable <- getSelection(variableBox) group <- getSelection(groupBox) group2 <- getSelection(group2Box) color <- tclvalue(colorVariable) beside <- tclvalue(besideVariable) percent <- tclvalue(percentVariable) variablemembers <- eval(parse(text=paste("length(levels(factor(", ActiveDataSet(), "$", variable, ")))", sep=""))) if (color == 0){ color <- NULL } else { color <- paste(", col=c(2:", variablemembers+1, ")", sep="") } if (beside == 0){ beside <- NULL } else { beside <- ", beside=TRUE" } subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } putDialog("StatMedBarGraph", list(variable=variable, group=group, group2=group2, color=tclvalue(colorVariable), beside=tclvalue(besideVariable), percent=percent, subset=tclvalue(subsetVariable))) closeDialog() if (length(variable) == 0){ errorCondition(recall=StatMedBarGraph, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (length(group) == 0){ command <- paste("barplot(table(", subset1, ActiveDataSet(), subset2, "$", variable, '), xlab="', variable, '", ylab="Frequency"', color, ", axis.lty=1)", sep="") } else if (length(group2) == 0){ if(percent == 0){ command <- paste("barplot(table(", subset1, ActiveDataSet(), subset2, "$", variable, ",", subset1, ActiveDataSet(), subset2, "$", group, '), xlab="', group, '", ylab="Frequency"', color, beside, ", legend=levels(factor(", subset1, ActiveDataSet(), subset2, "$", variable, ')), args.legend=list(title="', variable, '", box.lty=0), axis.lty=1)', sep="") } else{ command <- paste("barplot(prop.table(table(", subset1, ActiveDataSet(), subset2, "$", variable, ",", subset1, ActiveDataSet(), subset2, "$", group, '),2), xlab="', group, '", ylab="Frequency"', color, beside, ", legend=levels(factor(", subset1, ActiveDataSet(), subset2, "$", variable, ')), args.legend=list(title="', variable, '", box.lty=0), axis.lty=1)', sep="") } } else { command <- paste('BarplotFor3Factors(First="', variable, '", Second="', group, '", Third="', group2, '", data="', subset1, ActiveDataSet(), subset2, '", prop=', percent, ", col=", tclvalue(colorVariable), ")", sep="") } logger(command) justDoIt(command) activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="barplot", apply="StatMedBarGraph", reset="StatMedBarGraph") tkgrid(getFrame(variableBox), labelRcmdr(variablesFrame, text=gettextRcmdr(" ")), getFrame(groupBox), labelRcmdr(variablesFrame, text=gettextRcmdr(" ")), getFrame(group2Box), sticky="w") tkgrid(variablesFrame, sticky="w") # tkgrid(color, sticky="w") # tkgrid(beside, sticky="w") # tkgrid(percent, sticky="w") tkgrid(optionsFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Side by side graph not created when 2 grouping variables are picked.")), sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } StatMedPieChart <- function(){ defaults <- list(variable=NULL, color=1, scale="percent", subset="") dialog.values <- getDialog("StatMedPieChart", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE Library("colorspace") #conflicts with pROC package:coords and therefore use pROC::coords in ROC function initializeDialog(title=gettextRcmdr("Pie chart(Frequencies)")) variableBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$variable, "all")) checkBoxes(frame="color", boxes=c("color"),initialValues=dialog.values$color,labels=gettextRcmdr(c("Draw in color"))) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Pie chart(Frequencies)"), "#####", sep="")) variable <- getSelection(variableBox) color <- tclvalue(colorVariable) scale <- tclvalue(scaleVariable) scale <- paste0(', scale="', scale, '"') subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } putDialog("StatMedPieChart", list(variable=variable, color=color, scale=tclvalue(scaleVariable), subset=tclvalue(subsetVariable))) closeDialog() if (length(variable) == 0){ errorCondition(recall=StatMedPieChart, message=gettextRcmdr("You must select a variable")) return() } .activeDataSet <- ActiveDataSet() variablemembers <- eval(parse(text=paste("length(levels(factor(", subset1, .activeDataSet, subset2, "$", variable, ")))", sep=""))) if (color == 0){ color <- ", col=(gray(c(0.9" gray = 0.9 if(variablemembers >= 2){ for (i in 2:variablemembers){ gray <- gray - (1 / variablemembers) color <- paste(color, ", ", gray, sep="") } } color <- paste(color, ")))", sep="") } else { # color <- paste(", col=c(2:", variablemembers+1, ")", sep="") color <- paste(", col=rainbow_hcl(", variablemembers, ")", sep="") } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} # command <- (paste("pie(table(", subset1, .activeDataSet, subset2, "$", variable, "), labels=levels(factor(", # .activeDataSet, "$", variable, ')), main="', variable, '"', color, scale, ", clockwise=TRUE)", sep="")) command <- (paste("piechart(", subset1, .activeDataSet, subset2, "$", variable, ', main="', variable, '"', color, scale, ", clockwise=TRUE)", sep="")) logger(command) justDoIt(command) activateMenus() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="pie", apply="StatMedPieChart", reset="StatMedPieChart") tkgrid(getFrame(variableBox), sticky="nw") tkgrid(color, sticky="w") radioButtons(name = "scale", buttons = c("percent", "frequency", "none"), values=c("percent", "frequency", "none"), labels = gettextRcmdr(c("Percentages", "Frequency counts", "Neither")), title = gettextRcmdr("Include in Segment Labels"), initialValue = dialog.values$scale) tkgrid(scaleFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=3, columns=1) } StatMedEnterTable <- function(){ env <- environment() Library("abind") initializeDialog(title=gettextRcmdr("Enter and analyze two-way table")) outerTableFrame <- tkframe(top) assign(".tableFrame", tkframe(outerTableFrame), envir=env) setUpTable <- function(...){ tkdestroy(get(".tableFrame", envir=env)) assign(".tableFrame", tkframe(outerTableFrame), envir=env) nrows <- as.numeric(tclvalue(rowsValue)) ncols <- as.numeric(tclvalue(colsValue)) make.col.names <- "labelRcmdr(.tableFrame, text='')" for (j in 1:ncols) { col.varname <- paste(".colname.", j, sep="") assign(col.varname, tclVar(j), envir=env) make.col.names <- paste(make.col.names, ", ", "ttkentry(.tableFrame, width='5', textvariable=", col.varname, ")", sep="") } eval(parse(text=paste("tkgrid(", make.col.names, ")", sep="")), envir=env) for (i in 1:nrows){ varname <- paste(".tab.", i, ".1", sep="") assign(varname, tclVar("") , envir=env) row.varname <- paste(".rowname.", i, sep="") assign(row.varname, tclVar(i), envir=env) make.row <- paste("ttkentry(.tableFrame, width='5', textvariable=", row.varname, ")", sep="") make.row <- paste(make.row, ", ", "ttkentry(.tableFrame, width='5', textvariable=", varname, ")", sep="") for (j in 2:ncols){ varname <- paste(".tab.", i, ".", j, sep="") assign(varname, tclVar(""), envir=env) make.row <- paste(make.row, ", ", "ttkentry(.tableFrame, width='5', textvariable=", varname, ")", sep="") } eval(parse(text=paste("tkgrid(", make.row, ")", sep="")), envir=env) } tkgrid(get(".tableFrame", envir=env), sticky="w") } rowColFrame <- tkframe(top) rowsValue <- tclVar("2") colsValue <- tclVar("2") setUpTable() #Added from version 1.53 dur to changes in Rcmdr ver 2.70 rowsSlider <- tkscale(rowColFrame, from=2, to=10, showvalue=FALSE, variable=rowsValue, resolution=1, orient="horizontal", command=setUpTable) rowsShow <- labelRcmdr(rowColFrame, textvariable=rowsValue, width=2, justify="right") colsSlider <- tkscale(rowColFrame, from=2, to=10, showvalue=FALSE, variable=colsValue, resolution=1, orient="horizontal", command=setUpTable) colsShow <- labelRcmdr(rowColFrame, textvariable=colsValue, width=2, justify="right") onOK <- function(){ logger(paste("#####", gettextRcmdr("Enter and analyze two-way table"), "#####", sep="")) nrows <- as.numeric(tclvalue(rowsValue)) ncols <- as.numeric(tclvalue(colsValue)) cell <- 0 counts <- rep(NA, nrows*ncols) row.names <- rep("", nrows) col.names <- rep("", ncols) for (i in 1:nrows) row.names[i] <- eval(parse(text=paste("tclvalue(", paste(".rowname.", i, sep=""),")", sep=""))) for (j in 1:ncols) col.names[j] <- eval(parse(text=paste("tclvalue(", paste(".colname.", j, sep=""),")", sep=""))) for (i in 1:nrows){ for (j in 1:ncols){ cell <- cell+1 varname <- paste(".tab.", i, ".", j, sep="") counts[cell] <- as.numeric(eval(parse(text=paste("tclvalue(", varname,")", sep="")))) } } counts <- na.omit(counts) if (length(counts) != nrows*ncols){ errorCondition(recall=StatMedEnterTable, message=sprintf(gettextRcmdr("Number of valid entries (%d)\nnot equal to number of rows (%d) * number of columns (%d)."), length(counts), nrows, ncols)) return() } if (length(unique(row.names)) != nrows){ errorCondition(recall=StatMedEnterTable, message=gettextRcmdr("Row names are not unique.")) return() } if (length(unique(col.names)) != ncols){ errorCondition(recall=StatMedEnterTable, message=gettextRcmdr("Column names are not unique.")) return() } percents <- as.character(tclvalue(percentsVariable)) chisq <- tclvalue(chisqVariable) chisqComp <- tclvalue(chisqComponentsVariable) expected <- tclvalue(expFreqVariable) fisher <- tclvalue(fisherVariable) closeDialog() command <- paste("matrix(c(", paste(counts, collapse=","), "), ", nrows, ", ", ncols, ", byrow=TRUE)", sep="") # assign(".Table", justDoIt(command), envir=.GlobalEnv) # logger(paste(".Table <- ", command, sep="")) doItAndPrint(".Table <- NULL") doItAndPrint(paste(".Table <- ", command, sep="")) command <- paste("c(",paste(paste("'", row.names, "'", sep=""), collapse=", "), ")", sep="") justDoIt(paste("rownames(.Table) <- ", command, sep="")) logger(paste("rownames(.Table) <- ", command, sep="")) command <- paste("c(",paste(paste("'", col.names, "'", sep=""), collapse=", "), ")", sep="") justDoIt(paste("colnames(.Table) <- ", command, sep="")) logger(paste("colnames(.Table) <- ", command, sep="")) doItAndPrint(".Table # Counts") if (percents == "row") doItAndPrint(gettextRcmdr("rowPercents(.Table) # Row Percentages")) if (percents == "column") doItAndPrint(gettextRcmdr("colPercents(.Table) # Column Percentages")) if (percents == "total") doItAndPrint(gettextRcmdr("totPercents(.Table) # Percentage of Total")) if (chisq == 1) { command <- "chisq.test(.Table, correct=TRUE)" # logger(paste(".Test <- ", command, sep="")) # assign(".Test", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(".Test <- ", command, sep="")) doItAndPrint(".Test") if (expected == 1) doItAndPrint(".Test$expected # Expected Counts") warnText <- NULL if (0 < (nlt1 <- sum(.Test$expected < 1))) warnText <- paste(nlt1, gettextRcmdr("expected frequencies are less than 1")) if (0 < (nlt5 <- sum(.Test$expected < 5))) warnText <- paste(warnText, "\n", nlt5, gettextRcmdr(" expected frequencies are less than 5"), sep="") if (!is.null(warnText)) Message(message=warnText, type="warning") if (chisqComp == 1) { command <- "round(.Test$residuals^2, 2) # Chi-square Components" doItAndPrint(command) } logger("remove(.Test)") remove(.Test, envir=.GlobalEnv) } if (fisher == 1) doItAndPrint("fisher.test(.Table)") if (fisher == 0 & chisq == 1){ doItAndPrint("res <- NULL") doItAndPrint("res <- chisq.test(.Table, correct=TRUE)") } else { doItAndPrint("res <- fisher.test(.Table)") } doItAndPrint("summary.table <- NULL") doItAndPrint("summary.table <- data.frame(cbind(.Table, p.value=signif(res$p.value, digits=3)))") doItAndPrint('summary.table$p.value[2:length(.Table[,1])] <- ""') if(fisher == 0 & chisq == 1){ doItAndPrint('colnames(summary.table)[length(.Table[1,])+1] <- gettextRcmdr( "Chisq.p.value")') } else { doItAndPrint('colnames(summary.table)[length(.Table[1,])+1] <- gettextRcmdr( "Fisher.p.value")') } # doItAndPrint("remove(res)") doItAndPrint("summary.table") # logger("remove(.Table)") # remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="fisher.test") radioButtons(name="percents", buttons=c("rowPercents", "columnPercents", "totalPercents", "nonePercents"), values=c("row", "column", "total", "none"), initialValue="none", labels=gettextRcmdr(c("Row percentages", "Column percentages", "Percentages of total", "No percentages")), title=gettextRcmdr("Compute Percentages")) checkBoxes(frame="testsFrame", boxes=c("chisq", "chisqComponents", "expFreq", "fisher"), initialValues=c("0", "0", "0", "1"), labels=gettextRcmdr(c("Chi-square test with continuity correction", "Components of chi-square statistic", "Print expected frequencies", "Fisher's exact test"))) tkgrid(labelRcmdr(rowColFrame, text=gettextRcmdr("Number of Rows:")), rowsSlider, rowsShow, sticky="w") tkgrid(labelRcmdr(rowColFrame, text=gettextRcmdr("Number of Columns:")), colsSlider, colsShow, sticky="w") tkgrid(rowColFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Enter counts:"), fg="blue"), sticky="w") tkgrid(outerTableFrame, sticky="w") tkgrid(percentsFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Hypothesis Tests"), fg="blue"), sticky="w") tkgrid(testsFrame, sticky="w") tkgrid(buttonsFrame, columnspan=2, sticky="w") dialogSuffix(rows=7, columns=2) } StatMedTwoWayTable <- function(){ # Library("abind") defaults <- list(row=NULL, column=NULL, percents="column", chisq=0, chisqComp=0, expected=0, fisher=1, continuity="TRUE", bonferroni=0, holm=0, subset="") dialog.values <- getDialog("StatMedTwoWayTable", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE Library("abind") initializeDialog(title=gettextRcmdr("Create two-way table and compare two proportions (Fisher's exact test)")) variablesFrame <- tkframe(top) .factors <- Variables() rowBox <- variableListBox(variablesFrame, .factors, selectmode="multiple", title=gettextRcmdr("Row variable (pick one or more)"), listHeight=10, initialSelection=varPosn(dialog.values$row, "all")) columnBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Column variable (pick one)"), listHeight=10, initialSelection=varPosn(dialog.values$column, "all")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Create two-way table and compare two proportions (Fisher's exact test)"), "#####", sep="")) row <- getSelection(rowBox) column <- getSelection(columnBox) percents <- as.character(tclvalue(percentsVariable)) chisq <- tclvalue(chisqTestVariable) chisqComp <- tclvalue(chisqComponentsVariable) expected <- tclvalue(expFreqVariable) fisher <- tclvalue(fisherTestVariable) continuity <- tclvalue(continuityVariable) bonferroni <- tclvalue(bonferroniVariable) holm <- tclvalue(holmVariable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedTwoWayTable", list(row=row, column=column, percents=percents, chisq=chisq, chisqComp=chisqComp, expected=expected, fisher=fisher, continuity=continuity, bonferroni=bonferroni, holm=holm, subset=tclvalue(subsetVariable))) if (length(row) == 0 || length(column) == 0){ errorCondition(recall=StatMedTwoWayTable, message=gettextRcmdr("You must select two variables.")) return() } closeDialog() nvar = length(row) doItAndPrint("Fisher.summary.table <- NULL") doItAndPrint(".Table <- NULL") for (i in 1:nvar) { if (row[i] == column) { errorCondition(recall=StatMedTwoWayTable, message=gettextRcmdr("Row and column variables are the same.")) return() } command <- paste("xtabs(~", row[i], "+", column, ", data=", ActiveDataSet(), subset, ")", sep="") # logger(paste(".Table <- ", command, sep="")) # assign(".Table", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(".Table <- ", command, sep="")) doItAndPrint(".Table") if (percents == "row") doItAndPrint(gettextRcmdr("rowPercents(.Table) # Row Percentages")) if (percents == "column") doItAndPrint(gettextRcmdr("colPercents(.Table) # Column Percentages")) if (percents == "total") doItAndPrint(gettextRcmdr("totPercents(.Table) # Percentage of Total")) if (chisq == 1) { command <- paste("chisq.test(.Table, correct=", continuity, ")", sep="") # logger(paste(".Test <- ", command, sep="")) # assign(".Test", justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(".Test <- ", command, sep="")) doItAndPrint(".Test") if (expected == 1) doItAndPrint(".Test$expected # Expected Counts") warnText <- NULL if (0 < (nlt1 <- sum(.Test$expected < 1))) warnText <- paste(nlt1, gettextRcmdr("expected frequencies are less than 1")) if (0 < (nlt5 <- sum(.Test$expected < 5))) warnText <- paste(warnText, "\n", nlt5, gettextRcmdr(" expected frequencies are less than 5"), sep="") if (!is.null(warnText)) Message(message=warnText, type="warning") if (chisqComp == 1) { command <- "round(.Test$residuals^2, 2) # Chi-square Components" doItAndPrint(command) } logger("remove(.Test)") remove(.Test, envir=.GlobalEnv) } if (fisher == 1) doItAndPrint("fisher.test(.Table)") doItAndPrint("res <- NULL") if (fisher == 0 & chisq==1){ doItAndPrint(paste("res <- chisq.test(.Table, correct=", continuity, ")", sep="")) } else { doItAndPrint("res <- fisher.test(.Table)") } doItAndPrint("Fisher.summary.table <- rbind(Fisher.summary.table, summary.table.twoway(table=.Table, res=res))") # doItAndPrint("remove(res)") } doItAndPrint('colnames(Fisher.summary.table)[length(Fisher.summary.table)] <- gettextRcmdr( colnames(Fisher.summary.table)[length(Fisher.summary.table)])') doItAndPrint("Fisher.summary.table") # doItAndPrint("remove(Fisher.summary.table)") # logger("remove(.Table)") if (bonferroni == 1 && nvar == 1){ doItAndPrint(paste(".Table <- xtabs(~", column, "+", row[i], ", data=", ActiveDataSet(), subset, ")", sep="")) if(chisq==1){ doItAndPrint('pairwise.prop2.test(.Table, p.adj="bonferroni", test.function=chisq.test)') } if(fisher==1){ doItAndPrint('pairwise.prop2.test(.Table, p.adj="bonferroni", test.function=fisher.test)') } } if (holm == 1 && nvar == 1){ doItAndPrint(paste(".Table <- xtabs(~", column, "+", row[i], ", data=", ActiveDataSet(), subset, ")", sep="")) if(chisq==1){ doItAndPrint('pairwise.prop2.test(.Table, p.adj="holm", test.function=chisq.test)') } if(fisher==1){ doItAndPrint('pairwise.prop2.test(.Table, p.adj="holm", test.function=fisher.test)') } } # remove(.Table, envir=.GlobalEnv) # logger("remove(.Table)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="xtabs", apply="StatMedTwoWayTable", reset="StatMedTwoWayTable") radioButtons(name="percents", buttons=c("rowPercents", "columnPercents", "totalPercents", "nonePercents"), values=c("row", "column", "total", "none"), initialValue=dialog.values$percents, labels=gettextRcmdr(c("Row percentages", "Column percentages", "Percentages of total", "No percentages")), title=gettextRcmdr("Compute Percentages")) analysisFrame <- tkframe(top) checkBoxes(window=analysisFrame, frame="testsFrame", boxes=c("chisqTest", "chisqComponents", "expFreq", "fisherTest"), initialValues=c(dialog.values$chisq, dialog.values$chisqComp, dialog.values$expected, dialog.values$fisher),labels=gettextRcmdr(c("Chi-square test", "Components of chi-square statistic","Print expected frequencies", "Fisher's exact test"))) # checkBoxes(window=analysisFrame, frame="testsFrame", boxes=c("chisqTest", "chisqComponents", "expFreq", "fisherTest"), # initialValues=c("0", "0", "0", "1"), labels=gettextRcmdr(c("Chi-square test", "Components of chi-square statistic", # "Print expected frequencies", "Fisher's exact test"))) optionsFrame <- tkframe(top) tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison not performed when more than one grouping variables are picked."), fg="blue"), sticky="w") checkBoxes(frame="optionsFrame", boxes=c("bonferroni", "holm"), initialValues=c(dialog.values$bonferroni, dialog.values$holm),labels=gettextRcmdr(c("Pairwise comparison (Bonferroni)", "Pairwise comparison (Holm)"))) # bonferroniVariable <- tclVar("0") # bonferroniCheckBox <- tkcheckbutton(optionsFrame, variable=dialog.values$bonferroniVariable) # holmVariable <- tclVar("0") # holmCheckBox <- tkcheckbutton(optionsFrame, variable=dialog.values$holmVariable) radioButtons(analysisFrame, name="continuity", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue=dialog.values$continuity, labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Continuity correction of chi-square test")) # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Bonferroni)")), bonferroniCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Pairwise comparison (Holm)")), holmCheckBox, sticky="w") tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(rowBox), labelRcmdr(variablesFrame, text=" "), getFrame(columnBox), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(percentsFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Hypothesis Tests"), fg="blue"), sticky="w") tkgrid(testsFrame, labelRcmdr(analysisFrame, text=" "), continuityFrame, sticky="w") tkgrid(analysisFrame, sticky="nw") options2Frame <- tkframe(top) tkgrid(labelRcmdr(options2Frame, text=gettextRcmdr("Pairwise comparison not performed when more than one grouping variables are picked."), fg="blue"), sticky="w") tkgrid(options2Frame, sticky="nw") tkgrid(optionsFrame, sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedMcNemar <- function(){ defaults <- list(row=NULL, column=NULL, continuity="TRUE", subset="") dialog.values <- getDialog("StatMedMcNemar", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE # Library("abind") initializeDialog(title=gettextRcmdr("Compare proportions of two paired samples (McNemar test)")) variablesFrame <- tkframe(top) .factors <- Variables() rowBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Row variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$row, "all")) columnBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Column variable (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$column, "all")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Compare proportions of two paired samples (McNemar test)"), "#####", sep="")) row <- getSelection(rowBox) column <- getSelection(columnBox) continuity <- tclvalue(continuityVariable) subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) "" else paste(", subset=", subset, sep="") putDialog("StatMedMcNemar", list(row=row, column=column, continuity=continuity, subset=tclvalue(subsetVariable))) if (length(row) == 0 || length(column) == 0){ errorCondition(recall=StatMedMcNemar, message=gettextRcmdr("You must select two variables.")) return() } closeDialog() if (row == column) { errorCondition(recall=StatMedMcNemar, message=gettextRcmdr("Row and column variables are the same.")) return() } command <- paste("xtabs(~", row, "+", column, ", data=", ActiveDataSet(), subset, ")", sep="") # logger(paste(".Table <- ", command, sep="")) # assign(".Table", justDoIt(command), envir=.GlobalEnv) doItAndPrint(".Table <- NULL") doItAndPrint(paste(".Table <- ", command, sep="")) doItAndPrint(".Table") doItAndPrint("res <- NULL") command <- paste("(res <- mcnemar.test(.Table, correct=", continuity, "))", sep="") doItAndPrint(command) command <- paste('cat(gettextRcmdr( "McNemar', "'", 's test")', ', "', gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), '\n")', sep="") doItAndPrint(command) # doItAndPrint("remove(res)") # remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="mcnemar.test", apply="StatMedMcNemar", reset="StatMedMcNemar") tkgrid(getFrame(rowBox), labelRcmdr(variablesFrame, text=" "), getFrame(columnBox), sticky="nw") tkgrid(variablesFrame, sticky="w") radioButtons(name="continuity", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue=dialog.values$continuity, labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Continuity correction")) tkgrid(continuityFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedCochranQ <- function(){ defaults <- list(response=NULL, subset="") dialog.values <- getDialog("StatMedCochranQ", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Compare proportions of more than two paired samples (Cochran Q test)")) responseBox <- variableListBox(top, Variables(), selectmode="multiple", title=gettextRcmdr("Pick 2 or more paired binary variables"), listHeight=15, initialSelection=varPosn(dialog.values$response, "all")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Compare proportions of more than two paired samples (Cochran Q test)"), "#####", sep="")) responses <- getSelection(responseBox) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } putDialog("StatMedCochranQ", list(response=responses, subset=tclvalue(subsetVariable))) closeDialog() if (length(responses) < 2) { errorCondition(recall=StatMedCochranQ, message=gettextRcmdr("You must select at least two variables.")) return() } .activeDataSet <- ActiveDataSet() doItAndPrint(".Table <- NULL") command <- paste(".Table <- cbind(", subset1, .activeDataSet, subset2, "$", responses[1], sep="") for (i in 2:length(responses)){ command <- paste(command, ", ", subset1, .activeDataSet, subset2, "$", responses[i], sep="") } command <- paste(command, ")", sep="") doItAndPrint(command) doItAndPrint("res <- NULL") doItAndPrint("(res <- Cochran.Q.test(.Table))") command <- paste('cat(gettextRcmdr( "Cochran', "'", 's Q test")', ', "', gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), '\n")', sep="") doItAndPrint(command) # doItAndPrint("remove(res)") # doItAndPrint("remove(.Table)") tkfocus(CommanderWindow()) } OKCancelHelp(apply="StatMedCochranQ", reset="StatMedCochranQ") tkgrid(getFrame(responseBox), sticky="nw") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } StatMedPropTrend <- function(){ # Library("abind") defaults <- list(response=NULL, group=NULL, subset="") dialog.values <- getDialog("StatMedPropTrend", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Cochran-Armitage test for trend in proportions")) variablesFrame <- tkframe(top) .factors <- Variables() responseBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Binary varibale(Ex. No response=0, Response=1) (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "all")) groupBox <- variableListBox(variablesFrame, .factors, title=gettextRcmdr("Grouping variable(pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Cochran-Armitage test for trend in proportions"), "#####", sep="")) response <- getSelection(responseBox) group <- getSelection(groupBox) subset <- tclvalue(subsetVariable) subset <- if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) "" else paste(", subset=", subset, sep="") putDialog("StatMedPropTrend", list(response=response, group=group, subset=tclvalue(subsetVariable))) if (length(response) == 0 || length(group) == 0){ errorCondition(recall=StatMedPropTrend, message=gettextRcmdr("You must select two variables.")) return() } closeDialog() if (response == group) { errorCondition(recall=StatMedPropTrend, message=gettextRcmdr("Binary variable and grouping variable must be different.")) return() } command <- paste("xtabs(~", group, "+", response, ", data=", ActiveDataSet(), subset, ")", sep="") # logger(paste(".Table <- ", command, sep="")) # assign(".Table", justDoIt(command), envir=.GlobalEnv) doItAndPrint(".Table <- NULL") doItAndPrint(paste(".Table <- ", command, sep="")) doItAndPrint(".Table") doItAndPrint("res <- NULL") command <- "(res <- prop.trend.test(.Table[,1], .Table[,1]+.Table[,2]))" doItAndPrint(command) doItAndPrint('cat(gettextRcmdr( "Cochran-Armitage test for trend in proportions"), " ", gettextRcmdr( "p.value"), " = ", signif(res$p.value, digits=3), "\n", sep="")') # doItAndPrint("remove(res)") # remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="prop.trend.test", apply="StatMedPropTrend", reset="StatMedPropTrend") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Trend will be evaluated among groups in alphabetical order."), fg="blue"), sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedLogisticRegression <- function(){ defaults <- list(lhs = "", rhs = "", wald = 0, roc = 0, diagnosis = 0, actmodel = 0, pscore = 0, iptw = 0, stepwise1 = 0, stepwise2 = 0, stepwise3 = 0, subset = "") dialog.values <- getDialog("StatMedLogisticRegression", defaults) currentFields$lhs <- dialog.values$lhs #Values in currentFields will be sent to modelFormula currentFields$rhs <- dialog.values$rhs currentFields$subset <- dialog.values$subset initializeDialog(title=gettextRcmdr("Logistic regression")) .activeModel <- ActiveModel() currentModel <- if (!is.null(.activeModel)) #if current model exists, input to modelFormula class(get(.activeModel, envir=.GlobalEnv))[1] == "glm" # eval(parse(text=paste("class(", .activeModel, ")[1] == 'glm'", sep="")), # envir=.GlobalEnv) else FALSE # if (currentModel) { # currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv), glm=TRUE) # currentFields <- formulaFields(eval(parse(text=.activeModel), # envir=.GlobalEnv), glm=TRUE) # if (currentFields$data != ActiveDataSet()) currentModel <- FALSE # } currentModel <- TRUE StatMedModelFormula() UpdateModelNumber() modelName <- tclVar(paste("GLM.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) optionsFrame <- tkframe(top) checkBoxes(frame="checkboxFrame", boxes=c("wald", "actmodel", "roc", "diagnosis", "pscore", "iptw", "stepwise1", "stepwise2", "stepwise3"), initialValues=c(dialog.values$wald, dialog.values$actmodel, dialog.values$roc, dialog.values$diagnosis, dialog.values$pscore, dialog.values$iptw, dialog.values$stepwise1, dialog.values$stepwise2, dialog.values$stepwise3),labels=gettextRcmdr(c("Wald test for overall p-value for factors with >2 levels", "Keep results as active model for further analyses", "Show ROC curve", "Show basic diagnostic plots", "Make propensity score variable", "Inverse probability of treatment weighting", "Stepwise selection based on AIC", "Stepwise selection based on BIC", "Stepwise selection based on p-value"))) # waldVariable <- tclVar("0") # waldCheckBox <- tkcheckbutton(optionsFrame, variable=waldVariable) # actmodelVariable <- tclVar("0") # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) # stepwise1Variable <- tclVar("0") # stepwise1CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise1Variable) # stepwise2Variable <- tclVar("0") # stepwise2CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise2Variable) # stepwise3Variable <- tclVar("0") # stepwise3CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise3Variable) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Logistic regression"), "#####", sep="")) modelValue <- trim.blanks(tclvalue(modelName)) formula <- paste(tclvalue(lhsVariable), tclvalue(rhsVariable), sep=" ~ ") wald <- tclvalue(waldVariable) actmodel <- tclvalue(actmodelVariable) roc <- tclvalue(rocVariable) diagnosis <- tclvalue(diagnosisVariable) pscore <- tclvalue(pscoreVariable) iptw <- tclvalue(iptwVariable) stepwise1 <- tclvalue(stepwise1Variable) stepwise2 <- tclvalue(stepwise2Variable) stepwise3 <- tclvalue(stepwise3Variable) subset <- tclvalue(subsetVariable) #input values into dialog memory putDialog("StatMedLogisticRegression", list(lhs = tclvalue(lhsVariable), rhs = tclvalue(rhsVariable), wald = wald, roc = roc, diagnosis = diagnosis, actmodel = actmodel, pscore = pscore, iptw = iptw, stepwise1 = stepwise1, stepwise2 = stepwise2, stepwise3 = stepwise3, subset=tclvalue(subsetVariable))) check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedLogisticRegression, model=TRUE, message=gettextRcmdr("Left-hand side of model empty.")) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedLogisticRegression, model=TRUE, message=gettextRcmdr("Right-hand side of model empty.")) return() } if (!is.valid.name(modelValue)){ errorCondition(recall=StatMedLogisticRegression, model=TRUE, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue)) return() } if (is.element(modelValue, listGeneralizedLinearModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) closeDialog() StatMedLogisticRegression() return() } } closeDialog() if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } Library("aod") command <- paste("glm(", formula, ", family=binomial(logit), data=", ActiveDataSet(), subset, ")", sep="") # logger(paste(modelValue, " <- ", command, sep="")) # assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(modelValue, " <- ", command, sep="")) doItAndPrint(paste("summary(", modelValue, ")", sep="")) x <- strsplit(tclvalue(rhsVariable), split="\\+") command <- paste("TempDF <- with(", ActiveDataSet(), ", ", ActiveDataSet(), "[complete.cases(", tclvalue(lhsVariable), ", ", paste(x[[1]], collapse=","), "),])", sep="") doItAndPrint(command) doItAndPrint(paste("GLM.null <- glm(", tclvalue(lhsVariable), "~1, family=binomial(logit), data=TempDF", subset, ")", sep="")) doItAndPrint(paste("anova(", modelValue, ', GLM.null, test="Chisq")', sep="")) nvar <- eval(parse(text=paste("length((coef(", modelValue, ")))", sep=""))) if(nvar>=3){ doItAndPrint(paste("vif(", modelValue, ")", sep="")) logger("###variance inflation factors") } doItAndPrint("odds <- NULL") doItAndPrint(paste("odds <- data.frame(exp( summary(", modelValue, ")$coef[,1:2] %*% rbind(c(1,1,1), 1.96*c(0,-1,1))))", sep="")) doItAndPrint(paste("odds <- cbind(odds, summary(", modelValue, ")$coefficients[,4])", sep="")) doItAndPrint("odds <- signif(odds, digits=3)") doItAndPrint('names(odds) <- gettextRcmdr(c("odds ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') doItAndPrint("odds") if (wald==1) doItAndPrint(paste("waldtest(", modelValue, ")", sep="")) if (roc==1){ Library("pROC") doItAndPrint("ROC <- NULL") # doItAndPrint(paste("ROC <- roc(", tclvalue(lhsVariable), " ~ ", modelValue, "$fitted.values, data=TempDF", subset, ', ci=TRUE, direction="auto")', sep="")) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ doItAndPrint(paste("ROC <- roc(TempDF$", tclvalue(lhsVariable), " ~ ", modelValue, '$fitted.values, ci=TRUE, direction="auto")', sep="")) } else { doItAndPrint(paste("ROC <- roc(subset(TempDF", subset, ")$", tclvalue(lhsVariable), " ~ ", modelValue, '$fitted.values, ci=TRUE, direction="auto")', sep="")) } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("plot(ROC)") doItAndPrint('cat(gettextRcmdr("Area under the curve"), signif(ROC$auc[1], digits=3), gettextRcmdr("95% CI"), signif(ROC$ci[1], digits=3), "-", signif(ROC$ci[3], digits=3), "\n")') # doItAndPrint("remove(ROC)") } if (diagnosis==1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("oldpar <- par(oma=c(0,0,3,0), mfrow=c(2,2))") doItAndPrint(paste("plot(", modelValue, ")", sep="")) doItAndPrint("par(oldpar)") } if (pscore==1 | iptw==1){ if(subset != ""){ logger(paste("#", gettextRcmdr("Subset analysis is not allowed in making propensity score or weighting variable."), sep="")) } else { command <- paste(ActiveDataSet(),"$PropensityScore.", modelValue, " <- fitted(", modelValue, ")", sep="") doItAndPrint(command) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("propensity.plot(group=", ActiveDataSet(), "$", tclvalue(lhsVariable), ", p.score=", ActiveDataSet(), "$PropensityScore.", modelValue, ")", sep="") doItAndPrint(command) logger(paste("#", gettextRcmdr("New variable"), " PropensityScore.", modelValue, " ", gettextRcmdr("was made."), sep="") ) } } if (iptw==1){ if(subset != ""){ logger(paste("#", gettextRcmdr("Subset analysis is not allowed in making propensity score or weighting variable."), sep="")) } else { command <- paste(ActiveDataSet(),"$weight.ATE.", modelValue, " <- IPTW.ATE(", modelValue, ")", sep="") doItAndPrint(command) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("propensity.plot(group=", ActiveDataSet(), "$", tclvalue(lhsVariable), ", p.score=", ActiveDataSet(), "$PropensityScore.", modelValue, ", weights=", ActiveDataSet(), "$weight.ATE.", modelValue, ")", sep="") doItAndPrint(command) logger(paste("#", gettextRcmdr("New variable"), " weight.ATE.", modelValue, " ", gettextRcmdr("was made."), sep="") ) } } if (pscore==1 | iptw==1){ activeDataSet(ActiveDataSet(), flushModel=FALSE) } if (stepwise1 == 1 | stepwise2 == 1 | stepwise3 == 1){ command <- paste("glm(", formula, ", family=binomial(logit), data=TempDF", subset, ")", sep="") doItAndPrint(paste(modelValue, " <- ", command, sep="")) } if (stepwise1 == 1){ doItAndPrint("res <- NULL") doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="AIC")', sep="")) doItAndPrint("odds <- data.frame(exp( summary(res)$coef[,1:2] %*% rbind(c(1,1,1), 1.96*c(0,-1,1))))") doItAndPrint(paste("odds <- cbind(odds, summary(res)$coefficients[,4])", sep="")) doItAndPrint("odds <- signif(odds, digits=3)") doItAndPrint('names(odds) <- c("odds ratio", "lower .95", "upper .95", "p.value")') doItAndPrint("summary(res)") doItAndPrint("odds") if (wald==1) doItAndPrint("waldtest(res)") # doItAndPrint("remove(res)") } if (stepwise2 == 1){ doItAndPrint("res <- NULL") doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="BIC")', sep="")) doItAndPrint("odds <- data.frame(exp( summary(res)$coef[,1:2] %*% rbind(c(1,1,1), 1.96*c(0,-1,1))))") doItAndPrint(paste("odds <- cbind(odds, summary(res)$coefficients[,4])", sep="")) doItAndPrint("odds <- signif(odds, digits=3)") doItAndPrint('names(odds) <- c("odds ratio", "lower .95", "upper .95", "p.value")') doItAndPrint("summary(res)") doItAndPrint("odds") if (wald==1) doItAndPrint("waldtest(res)") # doItAndPrint("remove(res)") } if (stepwise3 == 1){ subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" } else{ subset <- paste(", subset='", trim.blanks(subset), "'", sep="") } doItAndPrint(paste('step.p.glm(', modelValue, ', "TempDF", wald=', wald, subset, ")", sep="")) } # doItAndPrint("remove(odds)") if (actmodel==1) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="generalizedLinearModel", apply="StatMedLogisticRegression", reset="StatMedLogisticRegression") helpButton <- buttonRcmdr(buttonsFrame, text="Help", width="12", command=onHelp) tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Stratifing variable: + strata(#####)")), sticky="e") tkgrid(checkboxFrame, sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } StatMedKaplanMeier <- function(){ defaults <- list(event = "", timetoevent = "", group = "", strata = "", test = 0, line = "color", place = "topright", xscale = "1", posthoc = "", censor = 1, ci = 0, separatestrata = 0, atrisk = 1, point = "<none>", xlim = "<auto>", ylim = "<auto>", xlabel = "<auto>", ylabel = "<auto>", ypercent = 0, subset = "") dialog.values <- getDialog("StatMedKaplanMeier", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Kaplan-Meier survival curve and logrank test")) variablesFrame <- tkframe(top) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1) (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$event, "all")) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$timetoevent, "all")) variables2Frame <- tkframe(top) groupBox <- variableListBox(variables2Frame, Variables(), selectmode="multiple", title=gettextRcmdr("Grouping variable (pick 0, 1, or more)"), listHeight=8, initialSelection=varPosn(dialog.values$group, "all")) strataBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Stratifying variable (pick 0 or 1)"), listHeight=8, initialSelection=varPosn(dialog.values$strata, "all")) plotoptionFrame <- tkframe(top) radioButtons(plotoptionFrame, name="test", buttons=c("logrank", "wilcoxon"), values=c("0", "1"), initialValue=dialog.values$test, labels=gettextRcmdr(c("logrank", "Peto-Peto-Wilcoxon")), title=gettextRcmdr("Method")) radioButtons(plotoptionFrame, name="line", buttons=c("color", "type", "width"), values=c("color", "type", "width"), initialValue=dialog.values$line, labels=gettextRcmdr(c("Color", "Line type", "Line width")), title=gettextRcmdr("Line discrimination")) radioButtons(plotoptionFrame, name="place", buttons=c("topright", "bottom", "mouse"), values=c("topright", "bottom", "mouse"), initialValue=dialog.values$place, labels=gettextRcmdr(c("Upper right", "Bottom", "Mouse click")), title=gettextRcmdr("Legend")) radioButtons(plotoptionFrame, name="xscale", buttons=c("day", "daytomonth", "daytoyear", "monthtoyear"), values=c("1", "30.4375", "365.25", "12"), initialValue=dialog.values$xscale, labels=gettextRcmdr(c("As is", "Day to month", "Day to year", "Month to year")), title=gettextRcmdr("X axis")) radioButtons(plotoptionFrame, name="posthoc", buttons=c("No", "Bonferroni", "Holm"), values=c("", "bon", "holm"), initialValue=dialog.values$posthoc, labels=gettextRcmdr(c("No", "Bonferroni", "Holm")), title=gettextRcmdr("Post-hoc test\n(when only one grouping\nvariable picked)")) plotoption2Frame <- tkframe(top) checkBoxes(window=plotoption2Frame, frame="censor", boxes=c("censor"), initialValues=c(dialog.values$censor),labels=gettextRcmdr(c("Show censoring marks")), title=gettextRcmdr("Options")) checkBoxes(window=plotoption2Frame, frame="ci", boxes=c("ci"), initialValues=c(dialog.values$ci),labels=gettextRcmdr(c("Show 95% confidence intervals")), title=gettextRcmdr(" ")) checkBoxes(window=plotoption2Frame, frame="separatestrata", boxes=c("separatestrata"), initialValues=c(dialog.values$separatestrata),labels=gettextRcmdr(c("Show each strata separately")), title=gettextRcmdr(" ")) checkBoxes(window=plotoption2Frame, frame="atrisk", boxes=c("atrisk"), initialValues=c(dialog.values$atrisk),labels=gettextRcmdr(c("Show number at risk")), title=gettextRcmdr(" ")) checkBoxes(window=plotoption2Frame, frame="ypercent", boxes=c("ypercent"), initialValues=c(dialog.values$ypercent),labels=gettextRcmdr(c("Y axis with percentage")), title=gettextRcmdr(" ")) # checkBoxes(window=plotoption2Frame, frame="censor", boxes=c("censor"),initialValues=c(1),labels=gettextRcmdr(c("Show censoring marks"))) # checkBoxes(window=plotoption2Frame, frame="ci", boxes=c("ci"),initialValues=c(0),labels=gettextRcmdr(c("Show 95% confidence intervals"))) # checkBoxes(window=plotoption2Frame, frame="separatestrata", boxes=c("separatestrata"),initialValues=c(0),labels=gettextRcmdr(c("Show each strata separately"))) # checkBoxes(window=plotoption2Frame, frame="atrisk", boxes=c("atrisk"),initialValues=c(0),labels=gettextRcmdr(c("Show number at risk"))) axisFrame <- tkframe(top) axis2Frame <- tkframe(top) pointFrame <- tkframe(axisFrame) pointVariable <- tclVar(dialog.values$point) pointField <- ttkentry(pointFrame, width="20", textvariable=pointVariable) xlimFrame <- tkframe(axis2Frame) xlimVariable <- tclVar(dialog.values$xlim) xlimField <- ttkentry(axis2Frame, width="20", textvariable=xlimVariable) ylimFrame <- tkframe(axis2Frame) ylimVariable <- tclVar(dialog.values$ylim) ylimField <- ttkentry(axis2Frame, width="20", textvariable=ylimVariable) xlabelFrame <- tkframe(axis2Frame) xlabelVariable <- tclVar(dialog.values$xlabel) xlabelField <- ttkentry(axis2Frame, width="20", textvariable=xlabelVariable) ylabelFrame <- tkframe(axis2Frame) ylabelVariable <- tclVar(dialog.values$ylabel) ylabelField <- ttkentry(axis2Frame, width="20", textvariable=ylabelVariable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Kaplan-Meier survival curve and logrank test"), "#####", sep="")) event <- getSelection(eventBox) timetoevent <- getSelection(timetoeventBox) group <- getSelection(groupBox) strata <- getSelection(strataBox) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ sub1 <- "" sub2 <- "" subset <- "" } else{ sub1 <- "subset(" sub2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } if (length(strata) == 0){ strata2 <- "" } else{ strata2 <- paste("+strata(", strata, ")", sep="") } censor <- tclvalue(censorVariable) ci <- tclvalue(ciVariable) separatestrata <- tclvalue(separatestrataVariable) if (length(strata) == 0) separatestrata <- 0 atrisk <- tclvalue(atriskVariable) ypercent <- tclvalue(ypercentVariable) test <- as.character(tclvalue(testVariable)) line <- tclvalue(lineVariable) par.lwd <- get("par.lwd", envir=.GlobalEnv) if (line=="color") {line <- paste("col=1:32, lty=1, ", par.lwd, ", ", sep=""); line2 <- paste("col=1:32, lty=1, ", par.lwd, ", ", sep="")} if (line=="type") {line <- paste("col=1, lty=1:32, ", par.lwd, ", ", sep=""); line2 <- paste("col=1, lty=1:32, ", par.lwd, ", ", sep="")} if (line=="width") {line <- paste("col=1, lty=1, ", par.lwd, ":8, ", sep=""); line2 <- paste("col=1, lty=1, ", par.lwd, ":8, ", sep="")} par.cex <- get("par.cex", envir=.GlobalEnv) place <- tclvalue(placeVariable) if(place=="mouse"){ place <- "locator(1)" }else if (place=="topright"){ place <- '"topright"' }else{ place <- '"bottom", horiz=TRUE' } xscale <- tclvalue(xscaleVariable) # xscale2 <- "" # if (xscale!=""){ # xscale2 <- paste(" * ", xscale, sep="") # xscale <- paste(", xscale=", xscale, sep="") # } point <- tclvalue(pointVariable) if (point == "<none>") { point <- "" } else { # point <- paste(", time=", point, xscale2, sep="") point <- paste(", time=", point, sep="") } posthoc <- tclvalue(posthocVariable) xlim <- tclvalue(xlimVariable) ylim <- tclvalue(ylimVariable) xlabel <- tclvalue(xlabelVariable) ylabel <- tclvalue(ylabelVariable) if (xlabel == "<auto>") { xlabel <- paste(', xlab="', timetoevent, '"', sep="") } else { xlabel <- paste(', xlab="', xlabel, '"', sep="") } if (ylabel == "<auto>") { ylabel <- ', ylab="Probability"' } else { ylabel <- paste(', ylab="', ylabel, '"', sep="") } if (ypercent==0){ ypercent1 <- "" } else { ypercent1 <- ", yscale=100" } if (ypercent==1){ ylabel <- paste(substr(ylabel, 1, nchar(ylabel)-1), ' (%)"', sep="") } if (xlim == "<auto>") { xlim <- "" } else { xlim <- paste(", xlim=c(", xlim, ")", sep="") } if (ylim == "<auto>") { if (ypercent==0){ ylim <- "" } else { # ylim <- ", ylim=c(0, 100)" ylim <- ", ylim=c(0, 1)" #changed according to the change in survival 3.1-8 } } else { if (ypercent==0){ ylim <- paste(", ylim=c(", ylim, ")", sep="") } else { # ylim <- paste(", ylim=c(", ylim, ")*100", sep="") ylim <- paste(", ylim=c(", ylim, ")", sep="") #changed according to the change in survival 3.1-8 } } if (ci==0){ conf.int <- "FALSE" }else{ conf.int <- "TRUE" if (line==paste("col=1:32, lty=1, ", par.lwd, ", ", sep="")) line <- paste("col=rep(1:32, each=3), lty=1, ", par.lwd, ", ", sep="") if (line==paste("col=1, lty=1:32, ", par.lwd, ", ", sep="")) line <- paste("col=1, lty=rep(1:32, each=3), ", par.lwd, ", ", sep="") if (line==paste("col=1, lty=1, ", par.lwd, ":8, ", sep="")) line <- paste("col=1, lty=1, lwd=rep(", substring(par.lwd, nchar(par.lwd),nchar(par.lwd)), ":8, each=3), ", sep="") } if (censor==0){ censor <- ", mark.time=FALSE" }else{ censor <- ", mark.time=TRUE" } dataSet <- activeDataSet() putDialog("StatMedKaplanMeier", list(event = event, timetoevent = timetoevent, group = group, strata = strata, test = test, line = tclvalue(lineVariable), place = tclvalue(placeVariable), xscale = tclvalue(xscaleVariable), posthoc = posthoc, censor = tclvalue(censorVariable), ci = ci, separatestrata = separatestrata, atrisk = atrisk, ypercent = ypercent, point = tclvalue(pointVariable), xlim = tclvalue(xlimVariable), ylim = tclvalue(ylimVariable), xlabel = tclvalue(xlabelVariable), ylabel = tclvalue(ylabelVariable), subset = tclvalue(subsetVariable))) if (length(event) != 1) { errorCondition(recall=StatMedKaplanMeier, message=gettextRcmdr("Pick one status indicator (censor=0, event=1)")) return() } if (length(timetoevent) != 1) { errorCondition(recall=StatMedKaplanMeier, message=gettextRcmdr("Pick one time-to-event variable")) return() } closeDialog() Library("survival") nvar <- length(group) doItAndPrint("km <- NULL") doItAndPrint("km.summary.table <- NULL") if (nvar == 0){ command <- paste("km <- survfit(Surv((", timetoevent, "/", xscale, "),", event, "==1)~1, data=", ActiveDataSet(), subset, ', na.action = na.omit, conf.type="log-log")', sep="") doItAndPrint(command) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} if (atrisk==0){ # doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, ypercent1, xlabel, ylabel, xscale, ")", sep="")) doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, ypercent1, xlabel, ylabel, ")", sep="")) } else { doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + 1 + 0.5") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, ypercent1, xlabel, ylabel, xscale, ")", sep="")) doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, ypercent1, xlabel, ylabel, ")", sep="")) doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(km, xticks", xscale2, ")", sep="")) doItAndPrint("n.atrisk <- nrisk(km, xticks)") doItAndPrint("axis(1, at = xticks, labels = n.atrisk, line = 3, tick = FALSE)") doItAndPrint('title(xlab = "Number at risk", line = 3, adj = 0)') } doItAndPrint("summary(km)") doItAndPrint(paste("summary.km(survfit=km", point, ")", sep="")) } else { for (i in 1:nvar) { command <- paste("km <- survfit(Surv((", timetoevent, "/", xscale, "),", event, "==1)~", group[i], strata2, ", data=", ActiveDataSet(), subset, ', na.action = na.omit, conf.type="log-log")', sep="") doItAndPrint(command) doItAndPrint("summary(km)") # doItAndPrint('legend <- c("0", "1")') #to create a legend vector. "0", "1" are dummy. if (length(strata) == 0 || separatestrata == 1){ strata3 <- "" doItAndPrint(paste('len <- nchar("', group[i], '")', sep="")) # doItAndPrint("nvar2 <- length(names(km$strata))") # doItAndPrint("k <- 1") # doItAndPrint("for (j in 1:nvar2){legend[k] <- levels(factor(substring(names(km$strata), len+2)))[j]; k <- k+1}") doItAndPrint("legend <- substring(names(km$strata), len+2)") }else{ #To remove groups with n=0 by interaction() suggested by Dr. Yoshida doItAndPrint(paste("legend <- levels(factor(interaction(", sub1, dataSet, sub2, "$", strata, ", ", sub1, dataSet, sub2, "$", group[i], ', sep=":")))', sep="")) strata3 <- paste(strata, " : ", sep="") } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} if (separatestrata == 0){ if (atrisk==0){ # doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, xlabel, ylabel, xscale, ")", sep="")) doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, xlabel, ylabel, ")", sep="")) doItAndPrint(paste("legend (", place, ", legend, ", line2, ' box.lty=0, title="', strata3, group[i], '")', sep="")) } else{ doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + length(km$strata) + 0.5") doItAndPrint("mar[2] <- mar[2] + 2") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, ypercent1, xlabel, ylabel, xscale, ")", sep="")) doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, ypercent1, xlabel, ylabel, ")", sep="")) doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(km, xticks", xscale2, ")", sep="")) doItAndPrint("n.atrisk <- nrisk(km, xticks)") doItAndPrint("for (i in 1:length(km$strata)){axis(1, at = xticks, labels = n.atrisk[i,], line=3+i, tick = FALSE)}") # doItAndPrint(paste('#for (i in 1:length(km$strata)){for (j in 1:(length(xticks)-1)) {axis(1, at=c(xticks[j]+(xticks[2]-xticks[1])/3, xticks[j+1]-+(xticks[2]-xticks[1])/3), labels=c(" ", " "), line=4.6+i, ', line2, "lwd.ticks=0, tick = TRUE)}}", sep="")) doItAndPrint(paste("for (i in 1:length(km$strata)){mtext(legend[i], at=-(xticks[2]-xticks[1])/2, side=1, line=4+i, cex=", par.cex, ")}", sep="")) doItAndPrint('title(xlab = "Number at risk", line = 3.5, adj = 0)') doItAndPrint(paste("legend (", place, ", legend, ", line2, ' box.lty=0, title="', strata3, group[i], '")', sep="")) } }else{ if (subset == ""){ stratas <- eval(parse(text=paste("levels(factor(", dataSet, "$", strata, "))", sep=""))) }else{ stratas <- eval(parse(text=paste("levels(factor(subset(", dataSet, ", ", tclvalue(subsetVariable), ")$", strata, "))", sep=""))) } nstrata <- length(stratas) doItAndPrint("strata.names <- NULL") doItAndPrint("strata.p <- NULL") for(j in 1: nstrata){ # command <- paste("km <- survfit(Surv(", timetoevent, ",", event, ")~", group[i], strata2, ", data=", dataSet, "[", dataSet, "$", strata, '=="', stratas[j], '",]', subset, ', na.action = na.omit, conf.type="log-log")', sep="") command <- paste("km <- survfit(Surv((", timetoevent, "/", xscale, "),", event, "==1)~", group[i], ", data=", dataSet, "[", dataSet, "$", strata, '=="', stratas[j], '",]', subset, ', na.action = na.omit, conf.type="log-log")', sep="") doItAndPrint(command) doItAndPrint(paste('len <- nchar("', group[i], '")', sep="")) doItAndPrint("nvar2 <- length(names(km$strata))") # doItAndPrint("k <- 1; legend <- NULL") # doItAndPrint("for (j in 1:nvar2){legend[k] <- levels(factor(substring(names(km$strata), len+2)))[j]; k <- k+1}") doItAndPrint("legend <- substring(names(km$strata), len+2)") main <- paste(', main="', strata, "=", stratas[j], '"', sep="") if (atrisk==0){ # doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, ypercent1, xlabel, ylabel, main, xscale, ")", sep="")) doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, ypercent1, xlabel, ylabel, main, ")", sep="")) doItAndPrint(paste("legend (", place, ", legend, ", line2, 'box.lty=0, title="', strata3, group[i], '")', sep="")) }else{ doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + length(km$strata) + 0.5") doItAndPrint("mar[2] <- mar[2] + 2") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, xlabel, ylabel, main, xscale, ")", sep="")) doItAndPrint(paste('plot(km, bty="l", ', line, "conf.int=", conf.int, censor, xlim, ylim, xlabel, ylabel, main, ")", sep="")) doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(km, xticks", xscale2, ")", sep="")) doItAndPrint("n.atrisk <- nrisk(km, xticks)") doItAndPrint("for (i in 1:length(km$strata)){axis(1, at = xticks, labels = n.atrisk[i,], line=3+i, tick = FALSE)}") # doItAndPrint(paste('#for (i in 1:length(km$strata)){for (j in 1:(length(xticks)-1)) {axis(1, at=c(xticks[j]+(xticks[2]-xticks[1])/3, xticks[j+1]-+(xticks[2]-xticks[1])/3), labels=c(" ", " "), line=4.6+i, ', line2, "lwd.ticks=0, tick = TRUE)}}", sep="")) doItAndPrint(paste("for (i in 1:length(km$strata)){mtext(legend[i], at=-(xticks[2]-xticks[1])/2, side=1, line=4+i, cex=", par.cex, ")}", sep="")) doItAndPrint('title(xlab = "Number at risk", line = 3.5, adj = 0)') doItAndPrint(paste("legend (", place, ", legend, ", line2, ' box.lty=0, title="', strata3, group[i], '")', sep="")) } if (subset == ""){ levs <- eval(parse(text=paste("length(levels(factor(", dataSet, "[", dataSet, "$", strata, '=="', stratas[j], '",]$', group[i], ")))", sep=""))) } else { levs <- eval(parse(text=paste("length(levels(factor(subset(", dataSet, ", ", tclvalue(subsetVariable), ")[subset(", dataSet, ", ", tclvalue(subsetVariable), ")$", strata, '=="', stratas[j], '",]$', group[i], ")))", sep=""))) } if (levs < 2){ doItAndPrint(paste('strata.names <- c(strata.names, "', stratas[j], '")', sep="")) doItAndPrint(paste("strata.p <- c(strata.p, NA)", sep="")) }else{ doItAndPrint("res <- NULL") command2 <- paste("res <- survdiff(Surv(", timetoevent, ",", event, "==1)~", group[i], strata2, ", data=", dataSet, "[", dataSet, "$", strata, '=="', stratas[j], '",]', subset, ", rho=", test, ", na.action = na.omit)", sep="") doItAndPrint(command2) doItAndPrint(paste('strata.names <- c(strata.names, "', stratas[j], '")', sep="")) doItAndPrint(paste("strata.p <- c(strata.p, signif(pchisq(c(res$chisq), df=length(res$n)-1, lower.tail=FALSE),digits=3))", sep="")) # doItAndPrint("remove(res)") } if (j < nstrata) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} } doItAndPrint(paste("strata.data <- data.frame(", strata, "=strata.names, p.value=strata.p)", sep="")) logger("p-value calculated in each strata") doItAndPrint("strata.data") # doItAndPrint("remove(strata.data)") command <- paste("km <- survfit(Surv((", timetoevent, "/", xscale, "),", event, "==1)~", group[i], strata2, ", data=", ActiveDataSet(), subset, ', na.action = na.omit, conf.type="log-log")', sep="") doItAndPrint(command) #To create km.summary.table in all strata } # command <- paste("km <- survfit(Surv(", timetoevent, ",", event, "==1)~", group[i], strata2, ", data=", ActiveDataSet(), subset, ', na.action = na.omit, conf.type="log-log")', sep="") # doItAndPrint(command) doItAndPrint("res <- NULL") command2 <- paste("(res <- survdiff(Surv(", timetoevent, ",", event, "==1)~", group[i], strata2, ", data=", dataSet, subset, ", rho=", test, ', na.action = na.omit))', sep="") doItAndPrint(command2) if (i == 1){ doItAndPrint(paste("km.summary.table <- summary.km(survfit=km, survdiff=res", point, ")", sep="")) } else { doItAndPrint(paste("km.summary.table <- rbind(km.summary.table, summary.km(survfit=km, survdiff=res", point, "))", sep="")) } if(nvar==1 & posthoc!=""){ if (length(strata)==0) { command <- paste("pairwise.logrank.test(", sub1, dataSet, sub2, "$", timetoevent, ", ", sub1, dataSet, sub2, "$", event, ", ", sub1, dataSet, sub2, "$", group[i], ', strata=NULL, "', dataSet, '", p.adjust.method="', posthoc, '", rho=', test, ")", sep="") } else{ command <- paste("pairwise.logrank.test(", sub1, dataSet, sub2, "$", timetoevent, ", ", sub1, dataSet, sub2, "$", event, ", ", sub1, dataSet, sub2, "$", group[i], ", strata=", sub1, dataSet, sub2, "$", strata, ', "', dataSet, '", p.adjust.method="', posthoc, '", rho=', test, ")", sep="") } doItAndPrint(command) } # doItAndPrint("remove(res)") } doItAndPrint("km.summary.table") # doItAndPrint("remove(km.summary.table)") } # doItAndPrint("remove(km)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="survfit", model=TRUE, apply="StatMedKaplanMeier", reset="StatMedKaplanMeier") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(variables2Frame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(groupBox), labelRcmdr(variables2Frame, text=" "), getFrame(strataBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(testFrame, labelRcmdr(plotoptionFrame, text=" "), lineFrame, labelRcmdr(plotoptionFrame, text=" "), placeFrame, labelRcmdr(plotoptionFrame, text=" "), xscaleFrame, labelRcmdr(plotoptionFrame, text=" "), posthocFrame, sticky="w") tkgrid(plotoptionFrame, sticky="nw") tkgrid(censor, labelRcmdr(plotoption2Frame, text=" "), ci, labelRcmdr(plotoption2Frame, text=" "), separatestrata, labelRcmdr(plotoption2Frame, text=" "), atrisk, labelRcmdr(plotoption2Frame, text=" "), ypercent, sticky="w") tkgrid(plotoption2Frame, sticky="nw") # tkgrid(plotoptionFrame, plotoption2Frame, sticky="nw") # tkgrid(plotoption2_1Frame, plotoption2_2Frame, sticky="w") # tkgrid(plotoption2Frame, sticky="w") tkgrid(labelRcmdr(pointFrame, text=gettextRcmdr("Time point to show survival rate")), pointField, sticky = "w") tkgrid(pointFrame, sticky="w") tkgrid(labelRcmdr(xlimFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimField, sticky = "w") tkgrid(labelRcmdr(ylimFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimField, sticky = "w") tkgrid(xlimFrame, labelRcmdr(axis2Frame, text=" "), ylimFrame, sticky="w") tkgrid(labelRcmdr(xlabelFrame, text=gettextRcmdr("X axis label")), xlabelField, sticky = "w") tkgrid(labelRcmdr(ylabelFrame, text=gettextRcmdr("Y axis label")), ylabelField, sticky = "w") tkgrid(xlabelFrame, labelRcmdr(axis2Frame, text=" "), ylabelFrame, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("Time point to show survival rate")), pointEntry, sticky="w") # tkgrid.configure(pointEntry, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimEntry, sticky="w") # tkgrid.configure(xlimEntry, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimEntry, sticky="w") # tkgrid.configure(ylimEntry, sticky="w") tkgrid(axisFrame, sticky="w") tkgrid(axis2Frame, sticky="w") StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedLogrankTrend <- function(){ defaults <- list(event = "", timetoevent = "", group = "", subset = "") dialog.values <- getDialog("StatMedLogrankTrend", defaults) initializeDialog(title=gettextRcmdr("Logrank trend test")) variablesFrame <- tkframe(top) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1) (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$event, "all")) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$timetoevent, "all")) variables2Frame <- tkframe(top) groupBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Grouping variable (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$group, "all")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Logrank trend test"), "#####", sep="")) event <- getSelection(eventBox) timetoevent <- getSelection(timetoeventBox) group <- getSelection(groupBox) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ sub1 <- "" sub2 <- "" subset <- "" } else{ sub1 <- "subset(" sub2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } dataSet <- activeDataSet() putDialog("StatMedLogrankTrend", list(event = event, timetoevent = timetoevent, group = group, subset = tclvalue(subsetVariable))) if (length(event) != 1) { errorCondition(recall=StatMedLogrankTrend, message=gettextRcmdr("Pick one status indicator (censor=0, event=1)")) return() } if (length(timetoevent) != 1) { errorCondition(recall=StatMedLogrankTrend, message=gettextRcmdr("Pick one time-to-event variable")) return() } closeDialog() Library("survival") nvar <- length(group) doItAndPrint("res <- NULL") command <- paste("(res <- survdiff(Surv(", timetoevent, ",", event, "==1)~", group, ", data=", dataSet, subset, ', na.action = na.omit))', sep="") doItAndPrint(command) doItAndPrint("logrank.trend(res)") # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="survdiff", model=TRUE, apply="StatMedLogrankTrend", reset="StatMedLogrankTrend") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(groupBox), labelRcmdr(variables2Frame, text=" "), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("Trend will be evaluated among groups in alphabetical order"), fg="blue"), sticky="w") StatMedSubsetBox() tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedCoxRegression <- function(){ # add the class coxph to the modelClasses, from fncCoxMode() in RcmdrPlugin.SurvivalT xx <- getRcmdr("modelClasses") bolCoxphExists = FALSE for(ii in 1:length(xx)){if (xx[ii] == "coxph") bolCoxphExists = TRUE} if (bolCoxphExists == FALSE) putRcmdr("modelClasses", c(getRcmdr("modelClasses"), "coxph")) defaults <- list(SurvivalTimeVariable = "", StatusVariable = "", rhs = "", waldVariable = 0, prophazVariable = 0, martinVariable = 0, basecurveVariable = 0, actmodelVariable = 0, stepwise1Variable = 0, stepwise2Variable = 0, stepwise3Variable = 0, subset = "") dialog.values <- getDialog("StatMedCoxRegression", defaults) currentFields$SurvivalTimeVariable <- dialog.values$SurvivalTimeVariable currentFields$StatusVariable <- dialog.values$StatusVariable currentFields$rhs <- dialog.values$rhs currentFields$subset <- dialog.values$subset initializeDialog(title=gettextRcmdr("Cox proportional hazard regression")) .activeModel <- ActiveModel() currentModel <- if (!is.null(.activeModel)) class(get(.activeModel, envir=.GlobalEnv))[1] == "coxph" # eval(parse(text=paste("class(", .activeModel, ")[1] == 'coxph'", sep="")), # envir=.GlobalEnv) else FALSE currentModel <- TRUE # if(currentModel){ # currentFields <- formulaFields(eval(parse(text=.activeModel), # envir=.GlobalEnv)) # if (currentFields$data != ActiveDataSet()) currentModel <- FALSE # } UpdateModelNumber() modelName <- tclVar(paste("CoxModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="30", textvariable=modelName) optionsFrame <- tkframe(top) checkBoxes(frame="checkboxFrame", boxes=c("wald", "prophaz", "martin", "basecurve", "actmodel", "stepwise1", "stepwise2", "stepwise3"), initialValues=c(dialog.values$waldVariable, dialog.values$prophazVariable, dialog.values$martinVariable, dialog.values$basecurveVariable, dialog.values$actmodelVariable, dialog.values$stepwise1Variabl, dialog.values$stepwise2Variabl, dialog.values$stepwise3Variabl),labels=gettextRcmdr(c("Wald test for overall p-value for factors with >2 levels", "Test proportional hazards assumption","Plot martingale residuals", "Show baseline survival curve", "Keep results as active model for further analyses", "Stepwise selection based on AIC", "Stepwise selection based on BIC", "Stepwise selection based on p-value"))) # waldVariable <- dialog.values$waldVariable # waldCheckBox <- tkcheckbutton(optionsFrame, variable=waldVariable) # prophazVariable <- dialog.values$prophazVariable # prophazCheckBox <- tkcheckbutton(optionsFrame, variable=prophazVariable) # basecurveVariable <- dialog.values$basecurveVariable # basecurveCheckBox <- tkcheckbutton(optionsFrame, variable=basecurveVariable) # actmodelVariable <- dialog.values$actmodelVariable # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) # stepwise1Variable <- dialog.values$stepwise1Variable # stepwise1CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise1Variable) # stepwise2Variable <- dialog.values$stepwise2Variable # stepwise2CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise2Variable) # stepwise3Variable <- dialog.values$stepwise3Variable # stepwise3CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise3Variable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Cox proportional hazard regression"), "#####", sep="")) # XXX <- getSelection(timeBox) modelValue <- trim.blanks(tclvalue(modelName)) wald <- tclvalue(waldVariable) prophaz <- tclvalue(prophazVariable) martin <- tclvalue(martinVariable) basecurve <- tclvalue(basecurveVariable) actmodel <- tclvalue(actmodelVariable) stepwise1 <- tclvalue(stepwise1Variable) stepwise2 <- tclvalue(stepwise2Variable) stepwise3 <- tclvalue(stepwise3Variable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" putRcmdr("modelWithSubset", FALSE) } else{ subset <- paste(", subset=", subset, sep="") putRcmdr("modelWithSubset", TRUE) } putDialog("StatMedCoxRegression", list(SurvivalTimeVariable = tclvalue(SurvivalTimeVariable), StatusVariable = tclvalue(StatusVariable), rhs = tclvalue(rhsVariable), waldVariable = wald, prophazVariable = prophaz, martinVariable = martin, basecurveVariable = basecurve, actmodelVariable = actmodel, stepwise1Variable = stepwise1, stepwise2Variable = stepwise2, stepwise3Variable = stepwise3, subset=tclvalue(subsetVariable))) if (!is.valid.name(modelValue)){ errorCondition(recall=StatMedCoxRegression, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } # check.empty <- gsub(" ", "", tclvalue(lhsVariable)) # if ("" == check.empty) { # errorCondition(recall=StatMedCoxRegression, # message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) # return() # } check.empty <- gsub(" ", "", tclvalue(SurvivalTimeVariable)) if ("" == check.empty) { errorCondition(recall=StatMedCoxRegression, message=gettextRcmdr("Survival time variable of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(StatusVariable)) if ("" == check.empty) { errorCondition(recall=StatMedCoxRegression, message=gettextRcmdr("Status variable of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedCoxRegression, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE) return() } if (is.element(modelValue, listCoxModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) StatMedCoxRegression() return() } } closeDialog() Library("survival") Library("aod") # formula <- paste("Surv(", XXX, ", ", tclvalue(lhsVariable), ") ~ ", tclvalue(rhsVariable), sep="") formula <- paste("Surv(", tclvalue(SurvivalTimeVariable), ", ", tclvalue(StatusVariable), "==1)~ ", tclvalue(rhsVariable), sep="") doItAndPrint("res <- NULL") command <- paste("coxph(", formula, ", data=", ActiveDataSet(), subset, ', method="breslow")', sep="") # logger(paste(modelValue, " <- ", command, sep="")) # assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(modelValue, " <- ", command, sep="")) doItAndPrint(paste("(res <- summary(", modelValue, "))", sep="")) # doItAndPrint(paste("res <- ", command, sep="")) # doItAndPrint("res <- summary(res)") doItAndPrint("cox.table <- NULL") if(eval(parse(text="length(res$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4)") #columns of p.value changes when weights option added doItAndPrint("rownames(cox.table) <- rownames(res$coefficients)") doItAndPrint('colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } else { doItAndPrint("cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } # doItAndPrint("cox.table <- signif(cox.table, digits=3)") doItAndPrint("cox.table") if (wald==1) doItAndPrint(paste("waldtest(", modelValue, ")", sep="")) if (martin==1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint(paste("scatter.smooth(residuals(", modelValue, ', type="martingale"))', sep="")) doItAndPrint("abline(h=0, lty=3)") } if (prophaz == 1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} nvar <- (eval(parse(text="length(cox.table[,1])"))) mfrow <- paste("c(4,", ceiling(nvar/4), ")", sep="") switch(as.character(nvar), "1"=mfrow <- "c(1,1)", "2"=mfrow <- "c(2,1)", "3"=mfrow <- "c(2,2)", "4"=mfrow <- "c(2,2)", "5"=mfrow <- "c(3,2)", "6"=mfrow <- "c(3,2)", "7"=mfrow <- "c(3,3)", "8"=mfrow <- "c(3,3)", "9"=mfrow <- "c(3,3)", "10"=mfrow <- "c(4,3)", "11"=mfrow <- "c(4,3)", "12"=mfrow <- "c(4,3)" ) doItAndPrint(paste("oldpar <- par(oma=c(0,0,3,0), mfrow=", mfrow, ")", sep="")) doItAndPrint(paste("plot(cox.zph(", modelValue, "), df=2)", sep="")) doItAndPrint("par(oldpar)") doItAndPrint(paste("print(cox.zph(", modelValue, "))", sep="")) } if (basecurve ==1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint(paste("plot(survfit(", modelValue, "))", sep="")) } if (stepwise1 == 1 | stepwise2 == 1 | stepwise3 == 1){ x <- strsplit(tclvalue(rhsVariable), split="\\+") command <- paste("TempDF <- with(", ActiveDataSet(), ", ", ActiveDataSet(), "[complete.cases(", paste(x[[1]], collapse=","), "),])", sep="") doItAndPrint(command) command <- paste("coxph(", formula, ", data=TempDF", subset, ', method="breslow")', sep="") doItAndPrint(paste(modelValue, " <- ", command, sep="")) } if (stepwise1 == 1){ doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="AIC")', sep="")) doItAndPrint("summary(res)") doItAndPrint("res2 <- summary(res)") if(eval(parse(text="length(res2$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res2$conf.int[,c(1,3,4)]), p.value=res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res2$coefficients)") doItAndPrint('colnames(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } else if(eval(parse(text="length(res2$coefficients[,1])"))>1){ doItAndPrint("cox.table <- signif(cbind(res2$conf.int[,c(1,3,4)], res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('names(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } if (wald==1) doItAndPrint("waldtest(res)") } if (stepwise2 == 1){ doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="BIC")', sep="")) doItAndPrint("summary(res)") doItAndPrint("res2 <- summary(res)") if(eval(parse(text="length(res2$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res2$conf.int[,c(1,3,4)]), p.value=res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res2$coefficients)") doItAndPrint('colnames(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } else if(eval(parse(text="length(res2$coefficients[,1])"))>1){ doItAndPrint("cox.table <- signif(cbind(res2$conf.int[,c(1,3,4)], res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('names(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } if (wald==1) doItAndPrint("waldtest(res)") } if (stepwise3 == 1){ subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" } else{ subset <- paste(", subset='", trim.blanks(subset), "'", sep="") } doItAndPrint(paste('step.p.cox(', modelValue, ', "TempDF", wald=', wald, subset, ")", sep="")) } # doItAndPrint("remove(res)") # doItAndPrint("remove(cox.table)") if (actmodel==1) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="coxph", model=TRUE, apply="StatMedCoxRegression", reset="StatMedCoxRegression") tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") modelFormulaCox() StatMedSubsetBox(model=TRUE) tkgrid(getFrame(xBox), sticky="w") # tkgrid(getFrame(xBox), getFrame(timeBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(labelRcmdr(top, text=paste(" ", gettextRcmdr("Stratifing variable: + strata(#####)"), sep="")), sticky="e") tkgrid(checkboxFrame, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Wald test for overall p-value for factors with >2 levels")), waldCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Test proportional hazards assumption")), prophazCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Show baseline survival curve")), basecurveCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Keep results as active model for further analyses")), actmodelCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on AIC")), stepwise1CheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on BIC")), stepwise2CheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on p-value")), stepwise3CheckBox, sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } StatMedAdjustedSurvival <- function(){ defaults <- list(event = "", timetoevent = "", group = "", adjust = "", line = "color", place = "topright", xscale = "1", censor = 1, atrisk = 1, xlim = "<auto>", ylim = "<auto>", xlabel = "<auto>", ylabel = "<auto>", ypercent = 0, subset = "") dialog.values <- getDialog("StatMedAdjustedSurvival", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Adjusted survival curve")) variablesFrame <- tkframe(top) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1) (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$event, "all")) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$timetoevent, "all")) variables2Frame <- tkframe(top) groupBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=8, initialSelection=varPosn(dialog.values$group, "all")) adjustBox <- variableListBox(variables2Frame, Variables(), selectmode="multiple", title=gettextRcmdr("Variables for adjustment (pick at least one)"), listHeight=8, initialSelection=varPosn(dialog.values$adjust, "all")) plotoptionFrame <- tkframe(top) radioButtons(plotoptionFrame, name="line", buttons=c("color", "type", "width"), values=c("color", "type", "width"), initialValue=dialog.values$line, labels=gettextRcmdr(c("Color", "Line type", "Line width")), title=gettextRcmdr("Line discrimination")) radioButtons(plotoptionFrame, name="place", buttons=c("topright", "bottom", "mouse"), values=c("topright", "bottom", "mouse"), initialValue=dialog.values$place, labels=gettextRcmdr(c("Upper right", "Bottom", "Mouse click")), title=gettextRcmdr("Legend")) radioButtons(plotoptionFrame, name="xscale", buttons=c("day", "daytomonth", "daytoyear", "monthtoyear"), values=c("1", "30.4375", "365.25", "12"), initialValue=dialog.values$xscale, labels=gettextRcmdr(c("As is", "Day to month", "Day to year", "Month to year")), title=gettextRcmdr("X axis")) plotoption2Frame <- tkframe(top) checkBoxes(window=plotoption2Frame, frame="censor", boxes=c("censor"),initialValues=dialog.values$censor,labels=gettextRcmdr(c("Show censoring marks")), title=gettextRcmdr("Options")) checkBoxes(window=plotoption2Frame, frame="atrisk", boxes=c("atrisk"),initialValues=dialog.values$atrisk,labels=gettextRcmdr(c("Show number at risk")), title=gettextRcmdr(" ")) checkBoxes(window=plotoption2Frame, frame="ypercent", boxes=c("ypercent"), initialValues=c(dialog.values$ypercent),labels=gettextRcmdr(c("Y axis with percentage")), title=gettextRcmdr(" ")) axisFrame <- tkframe(top) xlimFrame <- tkframe(axisFrame) xlimVariable <- tclVar(dialog.values$xlim) xlimField <- ttkentry(axisFrame, width="20", textvariable=xlimVariable) ylimFrame <- tkframe(axisFrame) ylimVariable <- tclVar(dialog.values$ylim) ylimField <- ttkentry(axisFrame, width="20", textvariable=ylimVariable) xlabelFrame <- tkframe(axisFrame) xlabelVariable <- tclVar(dialog.values$xlabel) xlabelField <- ttkentry(axisFrame, width="20", textvariable=xlabelVariable) ylabelFrame <- tkframe(axisFrame) ylabelVariable <- tclVar(dialog.values$ylabel) ylabelField <- ttkentry(axisFrame, width="20", textvariable=ylabelVariable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Adjusted survival curve"), "#####", sep="")) event <- getSelection(eventBox) timetoevent <- getSelection(timetoeventBox) group <- getSelection(groupBox) adjust <- getSelection(adjustBox) dataSet <- activeDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subdataSet <- dataSet naexcludeSubdataSet <- paste("subset(", dataSet, ", ", sep="") } else{ subdataSet <- paste("subset(", dataSet, ", ", subset, ")", sep="") naexcludeSubdataSet <- paste("subset(", dataSet, ", (", subset, ") & ", sep="") } line <- tclvalue(lineVariable) par.lwd <- get("par.lwd", envir=.GlobalEnv) if (line=="color") line <- paste("col=1:32, lty=1, ", par.lwd, ", ", sep="") if (line=="type") line <- paste("col=1, lty=1:32, ", par.lwd, ", ", sep="") if (line=="width") line <- paste("col=1, lty=1, ", par.lwd, ":8, ", sep="") par.cex <- get("par.cex", envir=.GlobalEnv) if(length(group)==0){line <- paste("col=1, lty=1, ", par.lwd, ", ", sep="")} place <- tclvalue(placeVariable) if(place=="mouse"){ place <- "locator(1)" }else if (place=="topright"){ place <- '"topright"' }else{ place <- '"bottom", horiz=TRUE' } censor <- tclvalue(censorVariable) atrisk <- tclvalue(atriskVariable) ypercent <- tclvalue(ypercentVariable) xscale <- tclvalue(xscaleVariable) # xscale2 <- "" # if (xscale!=""){ # xscale2 <- paste(" * ", xscale, sep="") # xscale <- paste(", xscale=", xscale, sep="") # } xlim <- tclvalue(xlimVariable) ylim <- tclvalue(ylimVariable) xlabel <- tclvalue(xlabelVariable) ylabel <- tclvalue(ylabelVariable) if (xlabel == "<auto>") { xlabel <- paste(', xlab="', timetoevent, '"', sep="") } else { xlabel <- paste(', xlab="', xlabel, '"', sep="") } if (ylabel == "<auto>") { ylabel <- ', ylab="Probability"' } else { ylabel <- paste(', ylab="', ylabel, '"', sep="") } if (ypercent==0){ ypercent1 <- "" } else { ypercent1 <- ", yscale=100" } if (ypercent==1){ ylabel <- paste(substr(ylabel, 1, nchar(ylabel)-1), ' (%)"', sep="") } if (xlim == "<auto>") { xlim <- "" } else { xlim <- paste(", xlim=c(", xlim, ")", sep="") } if (ylim == "<auto>") { if (ypercent==0){ ylim <- "" } else { # ylim <- ", ylim=c(0, 100)" ylim <- ", ylim=c(0, 1)" #changed according to the change in survival 3.1-8 } } else { if (ypercent==0){ ylim <- paste(", ylim=c(", ylim, ")", sep="") } else { # ylim <- paste(", ylim=c(", ylim, ")*100", sep="") ylim <- paste(", ylim=c(", ylim, ")", sep="") #changed according to the change in survival 3.1-8 } } if (censor==0){ censor <- ", mark.time=FALSE" }else{ censor <- ", mark.time=TRUE" } putDialog("StatMedAdjustedSurvival", list(event = event, timetoevent = timetoevent, group = group, adjust = adjust, line = tclvalue(lineVariable), place = tclvalue(placeVariable), xscale = tclvalue(xscaleVariable), censor = tclvalue(censorVariable), atrisk = atrisk, ypercent = ypercent, xlim = tclvalue(xlimVariable), ylim = tclvalue(ylimVariable), xlabel = tclvalue(xlabelVariable), ylabel = tclvalue(ylabelVariable), subset = tclvalue(subsetVariable))) if (length(event) != 1) { errorCondition(recall=StatMedAdjustedSurvival, message=gettextRcmdr("Pick one status indicator (censor=0, event=1)")) return() } if (length(timetoevent) != 1) { errorCondition(recall=StatMedAdjustedSurvival, message=gettextRcmdr("Pick one time-to-event variable")) return() } if (length(adjust) == 0) { errorCondition(recall=StatMedAdjustedSurvival, message=gettextRcmdr("Pick at least one variable for adjustment.")) return() } closeDialog() Library("survival") naexcludeSubdataSet <- paste(naexcludeSubdataSet, "(is.na(", group, ")==F", sep="") # naexcludeSubdataSet <- paste(naexcludeSubdataSet, "(is.na(", adjust[1], ")==F", sep="") factor <- adjust[1] if(length(adjust)>=1) naexcludeSubdataSet <- paste(naexcludeSubdataSet, " & is.na(", adjust[1], ")==F", sep="") if(length(adjust)>=2){ for (i in 2:length(adjust)){ factor <- paste(factor, " + ", adjust[i], sep="") naexcludeSubdataSet <- paste(naexcludeSubdataSet, " & is.na(", adjust[i], ")==F", sep="") } } factor2 <- factor naexcludeSubdataSet <- paste(naexcludeSubdataSet, "))", sep="") if (length(group)==1) factor2 <- paste(factor, " + strata(", group, ")", sep="") # command <- paste("coxmodel <- coxph(Surv((", timetoevent, "/", xscale, "), ", event, "==1)~ ", factor2, ", data=", subdataSet, ', method="breslow")', sep="") # use naexcludeSubdataset for rmean.table.adjusted() function. Can be replaced with complete.case() function. command <- paste("coxmodel <- coxph(Surv((", timetoevent, "/", xscale, "), ", event, "==1)~ ", factor2, ", data=", naexcludeSubdataSet, ', method="breslow")', sep="") doItAndPrint("coxmodel <- NULL") doItAndPrint(command) doItAndPrint("cox <- NULL") doItAndPrint('cox <- survfit(coxmodel, Conf.type="log-log")') if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} if(length(group)==1){ check.type <- eval(parse(text=paste(subdataSet, "$", group, sep=""))) if(is.integer(check.type) | is.numeric(check.type)){ doItAndPrint(paste('len <- nchar("', group, '")', sep="")) doItAndPrint("group.levels <- substring(names(cox$strata[cox$strata>0]),len+2)") } else { doItAndPrint("group.levels <- names(cox$strata[cox$strata>0])") } } if(atrisk==1){ if(length(group)==0){ doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + 1 + 0.5") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, xlabel, ylabel, xscale, ")", sep="") command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, ypercent1, xlabel, ylabel, ")", sep="") doItAndPrint(command3) doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(cox, xticks", xscale2, ")", sep="")) doItAndPrint("n.atrisk <- nrisk(cox, xticks)") doItAndPrint("axis(1, at = xticks, labels = n.atrisk, line = 3, tick = FALSE)") doItAndPrint('title(xlab = "Number at risk", line = 3, adj = 0)') } else { doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + length(cox$strata) + 0.5") doItAndPrint("mar[2] <- mar[2] + 2") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, xlabel, ylabel, xscale, ")", sep="") command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, ypercent1, xlabel, ylabel, ")", sep="") doItAndPrint(command3) doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(cox, xticks", xscale2, ")", sep="")) doItAndPrint("n.atrisk <- nrisk(cox, xticks)") doItAndPrint("for (i in 1:length(cox$strata)){axis(1, at = xticks, labels = n.atrisk[i,], line=3+i, tick = FALSE)}") # doItAndPrint(paste('#for (i in 1:length(cox$strata)){for (j in 1:(length(xticks)-1)) {axis(1, at=c(xticks[j]+(xticks[2]-xticks[1])/3, xticks[j+1]-+(xticks[2]-xticks[1])/3), labels=c(" ", " "), line=4.6+i, ', line2, "lwd.ticks=0, tick = TRUE)}}", sep="")) doItAndPrint(paste("for (i in 1:length(cox$strata)){mtext(group.levels[i], at=-(xticks[2]-xticks[1])/2, side=1, line=4+i, cex=", par.cex, ")}", sep="")) doItAndPrint('title(xlab = "Number at risk", line = 3.5, adj = 0)') # doItAndPrint(paste("legend (", place, ", legend, ", line, ' box.lty=0, title="', strata3, group[i], '")', sep="")) } } else { # command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, xlabel, ylabel, xscale, ")", sep="") command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, ypercent1, xlabel, ylabel, ")", sep="") doItAndPrint(command3) } if(length(group)==1){ doItAndPrint(paste("legend(", place, ', group.levels, title="', group, '", ', line, "box.lty=0)", sep="")) } doItAndPrint(paste('title("Survival curve adjusted for ', factor, '")', sep="")) doItAndPrint("summary(cox)") # doItAndPrint("remove(cox)") # doItAndPrint("remove(coxmodel)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="coxph", model=TRUE, apply="StatMedAdjustedSurvival", reset="StatMedAdjustedSurvival") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(variables2Frame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") tkgrid(getFrame(groupBox), labelRcmdr(variables2Frame, text=" "), getFrame(adjustBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(lineFrame, labelRcmdr(plotoptionFrame, text=" "), placeFrame, labelRcmdr(plotoptionFrame, text=" "), xscaleFrame, sticky="w") tkgrid(plotoptionFrame, sticky="nw") tkgrid(censor, labelRcmdr(plotoption2Frame, text=" "), atrisk, labelRcmdr(plotoption2Frame, text=" "), ypercent, sticky="w") tkgrid(plotoption2Frame, sticky="nw") tkgrid(labelRcmdr(xlimFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimField, sticky = "w") # tkgrid(xlimFrame, sticky="w") tkgrid(labelRcmdr(ylimFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimField, sticky = "w") # tkgrid(ylimFrame, sticky="w") tkgrid(xlimFrame, labelRcmdr(axisFrame, text=" "), ylimFrame, sticky="w") tkgrid(labelRcmdr(xlabelFrame, text=gettextRcmdr("X axis label")), xlabelField, sticky = "w") tkgrid(labelRcmdr(ylabelFrame, text=gettextRcmdr("Y axis label")), ylabelField, sticky = "w") tkgrid(xlabelFrame, labelRcmdr(axisFrame, text=" "), ylabelFrame, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimEntry, sticky="w") # tkgrid.configure(xlimEntry, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimEntry, sticky="w") # tkgrid.configure(ylimEntry, sticky="w") tkgrid(axisFrame, sticky="w") StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedCumInc <- function(){ defaults <- list(event = "", timetoevent = "", group = "", line = "color", place = "topright", xscale = "1", posthoc = "", censor = 1, atrisk = 1, point = "<none>", plotevent = "<all>", xlim = "<auto>", ylim = "<auto>", xlabel = "<auto>", ylabel = "<auto>", ypercent = 0, subset = "") dialog.values <- getDialog("StatMedCumInc", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Cumulative incidence of competing events and Gray test")) variablesFrame <- tkframe(top) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1,2,3...) (pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$event, "all")) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$timetoevent, "all")) variables2Frame <- tkframe(top) groupBox <- variableListBox(variables2Frame, Variables(), selectmode="multiple", title=gettextRcmdr("Grouping variable (pick 0, 1, or more)"), listHeight=6, initialSelection=varPosn(dialog.values$group, "all")) plotoptionFrame <- tkframe(top) radioButtons(plotoptionFrame, name="line", buttons=c("color", "type", "width"), values=c("color", "type", "width"), initialValue=dialog.values$line, labels=gettextRcmdr(c("Color", "Line type", "Line width")), title=gettextRcmdr("Line discrimination")) radioButtons(plotoptionFrame, name="place", buttons=c("topright", "bottom", "mouse"), values=c("topright", "bottom", "mouse"), initialValue=dialog.values$place, labels=gettextRcmdr(c("Upper right", "Bottom", "Mouse click")), title=gettextRcmdr("Legend")) radioButtons(plotoptionFrame, name="xscale", buttons=c("day", "daytomonth", "daytoyear", "monthtoyear"), values=c("1", "30.4375", "365.25", "12"), initialValue=dialog.values$xscale, labels=gettextRcmdr(c("As is", "Day to month", "Day to year", "Month to year")), title=gettextRcmdr("X axis")) radioButtons(plotoptionFrame, name="posthoc", buttons=c("No", "Bonferroni", "Holm"), values=c("", "bon", "holm"), initialValue=dialog.values$posthoc, labels=gettextRcmdr(c("No", "Bonferroni", "Holm")), title=gettextRcmdr("Post-hoc test (one event to show,\none grouping variable)")) plotoption2Frame <- tkframe(top) checkBoxes(window=plotoption2Frame, frame="censor", boxes=c("censor"), initialValues=c(dialog.values$censor),labels=gettextRcmdr(c("Show censoring marks")), title=gettextRcmdr("Options")) checkBoxes(window=plotoption2Frame, frame="atrisk", boxes=c("atrisk"), initialValues=c(dialog.values$atrisk),labels=gettextRcmdr(c("Show number at risk")), title=gettextRcmdr(" ")) checkBoxes(window=plotoption2Frame, frame="ypercent", boxes=c("ypercent"), initialValues=c(dialog.values$ypercent),labels=gettextRcmdr(c("Y axis with percentage")), title=gettextRcmdr(" ")) # checkBoxes(window=plotoption2Frame, frame="censor", boxes=c("censor"),initialValues=c(1),labels=gettextRcmdr(c("Show censoring marks"))) # checkBoxes(window=plotoption2Frame, frame="atrisk", boxes=c("atrisk"),initialValues=c(0),labels=gettextRcmdr(c("Show number at risk"))) axisFrame <- tkframe(top) axis2Frame <- tkframe(top) ploteventFrame <- tkframe(axisFrame) ploteventVariable <- tclVar(dialog.values$plotevent) ploteventField <- ttkentry(ploteventFrame, width="20", textvariable=ploteventVariable) pointFrame <- tkframe(axisFrame) pointVariable <- tclVar(dialog.values$point) pointField <- ttkentry(pointFrame, width="20", textvariable=pointVariable) xlimFrame <- tkframe(axis2Frame) xlimVariable <- tclVar(dialog.values$xlim) xlimField <- ttkentry(axis2Frame, width="20", textvariable=xlimVariable) ylimFrame <- tkframe(axis2Frame) ylimVariable <- tclVar(dialog.values$ylim) ylimField <- ttkentry(axis2Frame, width="20", textvariable=ylimVariable) xlabelFrame <- tkframe(axis2Frame) xlabelVariable <- tclVar(dialog.values$xlabel) xlabelField <- ttkentry(axis2Frame, width="20", textvariable=xlabelVariable) ylabelFrame <- tkframe(axis2Frame) ylabelVariable <- tclVar(dialog.values$ylabel) ylabelField <- ttkentry(axis2Frame, width="20", textvariable=ylabelVariable) # point <- tclVar("<none>") # pointEntry <- ttkentry(axisFrame, width="20", textvariable=point) # plotevent <- tclVar("<all>") # ploteventEntry <- ttkentry(axisFrame, width="20", textvariable=plotevent) # xlim <- tclVar("<auto>") # xlimEntry <- ttkentry(axisFrame, width="20", textvariable=xlim) # ylim <- tclVar("<auto>") # ylimEntry <- ttkentry(axisFrame, width="20", textvariable=ylim) onOK <- function(){ logger(paste("#####", gettextRcmdr("Cumulative incidence of competing events and Gray test"), "#####", sep="")) event <- getSelection(eventBox) timetoevent <- getSelection(timetoeventBox) group <- getSelection(groupBox) # strata <- getSelection(strataBox) dataSet <- activeDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subdataSet <- dataSet subset <- "" } else{ subdataSet <- paste("subset(", dataSet, ", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } line <- tclvalue(lineVariable) par.lwd <- get("par.lwd", envir=.GlobalEnv) if (line=="color") line <- paste("col=1:32, lty=1, ", par.lwd, sep="") if (line=="type") line <- paste("col=1, lty=1:32, ", par.lwd, sep="") if (line=="width") line <- paste("col=1, lty=1, ", par.lwd, ":8", sep="") par.cex <- get("par.cex", envir=.GlobalEnv) point <- tclvalue(pointVariable) if (point == "<none>") { point <- "" } else { point <- paste(", time=", point, sep="") } place <- tclvalue(placeVariable) if(place=="mouse"){ place <- "locator(1)" }else if (place=="topright"){ place <- '"topright"' }else{ place <- '"bottom", horiz=TRUE' } # color <- tclvalue(colorVariable) censor <- tclvalue(censorVariable) atrisk <- tclvalue(atriskVariable) ypercent <- tclvalue(ypercentVariable) if (censor==0){ censor <- ", mark.time=FALSE" }else{ censor <- ", mark.time=TRUE" } plotevent <- tclvalue(ploteventVariable) if (plotevent == "<all>" | plotevent == "") { plotline <- 0 } else { plotevent <- round(as.numeric(plotevent)) nevents <- eval(parse(text=paste("length(levels(factor(", subdataSet, "$", event, ")))", sep=""))) if (plotevent < 1 | plotevent > nevents){ plotline <- 0 } else { plotline <- plotevent } } xscale <- tclvalue(xscaleVariable) # xscale2 <- "" # if (xscale!=""){ # xscale2 <- paste(" * ", xscale, sep="") # xscale <- paste(", xscale=", xscale, sep="") # } posthoc <- tclvalue(posthocVariable) xlim <- tclvalue(xlimVariable) ylim <- tclvalue(ylimVariable) xlabel <- tclvalue(xlabelVariable) ylabel <- tclvalue(ylabelVariable) if (xlabel == "<auto>") { xlabel <- paste(', xlab="', timetoevent, '"', sep="") } else { xlabel <- paste(', xlab="', xlabel, '"', sep="") } if (ylabel == "<auto>") { ylabel <- ', ylab="Cumulative incidence"' } else { ylabel <- paste(', ylab="', ylabel, '"', sep="") } if (ypercent==0){ ypercent1 <- "" } else { ypercent1 <- ", yscale=100" } if (ypercent==1){ ylabel <- paste(substr(ylabel, 1, nchar(ylabel)-1), ' (%)"', sep="") } if (xlim == "<auto>") { xlim <- "" } else { xlim <- paste(", xlim=c(", xlim, ")", sep="") } if (ylim == "<auto>") { if (ypercent==0){ ylim <- ", ylim=c(0, 1)" } else { # ylim <- ", ylim=c(0, 100)" ylim <- ", ylim=c(0, 1)" #changed according to the change in survival 3.1-8 } } else { if (ypercent==0){ ylim <- paste(", ylim=c(", ylim, ")", sep="") } else { # ylim <- paste(", ylim=c(", ylim, ")*100", sep="") ylim <- paste(", ylim=c(", ylim, ")", sep="") #changed according to the change in survival 3.1-8 } } putDialog("StatMedCumInc", list(event = event, timetoevent = timetoevent, group = group, line = tclvalue(lineVariable), place = tclvalue(placeVariable), xscale = tclvalue(xscaleVariable), posthoc = posthoc, censor = tclvalue(censorVariable), atrisk = atrisk, ypercent = ypercent, point = tclvalue(pointVariable), plotevent = tclvalue(ploteventVariable), xlim = tclvalue(xlimVariable), ylim = tclvalue(ylimVariable), xlabel = tclvalue(xlabelVariable), ylabel = tclvalue(ylabelVariable), subset = tclvalue(subsetVariable))) if (length(event) != 1) { errorCondition(recall=StatMedCumInc, message=gettextRcmdr("Pick one status indicator (censor=0, event=1,2,3...)")) return() } if (length(timetoevent) != 1) { errorCondition(recall=StatMedCumInc, message=gettextRcmdr("Pick one time-to-event variable")) return() } # if (length(strata) ==0){ # strata <- "" # } # else{ # strata <- paste(strata, ", ", sep="") # } closeDialog() Library("survival") Library("cmprsk") # library(survival) # library(cmprsk) # justDoIt(paste("attach(",dataSet,")")) if(eval(parse(text=paste("min(", dataSet, "$", event, ", na.rm=TRUE)", sep="")))>0){ #no censoring in the dataset doItAndPrint(paste("DummyEventForCI <- ", dataSet, "$", event, sep="")) #only subset data will be used in the Surv() function, and therefore, all data should be included in the dummy data doItAndPrint('DummyEventForCI <- factor(DummyEventForCI, levels=c("0", levels(as.factor(DummyEventForCI)))) #Required for Surv() with mstate option') logger("#Making the smallest level of event as 0 to avoid the event with the smallest") logger("#event number will be treated as censoring when there are no censoring in the dataset.") } else { doItAndPrint(paste("DummyEventForCI <- ", dataSet, "$", event, sep="")) doItAndPrint("DummyEventForCI <- as.factor(DummyEventForCI) #Required for Surv() with mstate option") } doItAndPrint("res <- NULL") doItAndPrint("ci <- NULL") doItAndPrint("ci.summary.table <- NULL") nvar <- length(group) nevent <- eval(parse(text=paste("length(levels(factor(", subdataSet, "$", event, "[", subdataSet, "$", event, ">0])))", sep=""))) if (nvar == 0){ if(nevent==1){ command <- paste("ci <- survfit(Surv((", timetoevent, "/", xscale, "), ", event, ">0)~1, data=", dataSet, subset, ', conf.type="log-log")', sep="") #Error message appears when etype option is chosen and there is only single group with only 1 event type. doItAndPrint(command) doItAndPrint("if(is.null(ci$surv) & is.null(ci$prev)) ci$surv <- 1-ci$pstate") plotline <- 0 doItAndPrint("ci$surv <- 1-ci$surv") doItAndPrint("tempCI <- 1-ci$lower") doItAndPrint("ci$lower <- 1-ci$upper") doItAndPrint("ci$upper <- tempCI") doItAndPrint("summary(ci)") #To show cumulative incidence, substract from 1, and the add 1 for plot(). doItAndPrint("ci$surv <- 1-ci$surv") doItAndPrint("tempCI <- 1-ci$lower") doItAndPrint("ci$lower <- 1-ci$upper") doItAndPrint("ci$upper <- tempCI") } else { # command <- paste("ci <- survfit(Surv(", timetoevent, ", ", event, ">0)~1, data=", dataSet, subset, ", etype=", event, ")", sep="") command <- paste("ci <- survfit(Surv((", timetoevent, "/", xscale, '), DummyEventForCI, type="mstate")~1, data=', dataSet, subset, ', conf.type="log-log")', sep="") doItAndPrint(command) doItAndPrint("if(is.null(ci$surv) & is.null(ci$prev)) ci$surv <- 1-ci$pstate") command <- paste("res <- with(", dataSet, ", cuminc((", timetoevent, "/", xscale, "), ", event, ", cencode=0", subset, ", na.action = na.omit))", sep="") doItAndPrint(command) doItAndPrint("print.ci.summary(ci=ci)") } if(nevent>1){ if(plotline==0){ for (j in 1:nevent){ # if(j==1) {doItAndPrint(paste("ci.summary.table <- summary.ci(ci=ci, res=res, event=", j, point, xscale2, ")", sep="")) if(j==1) {doItAndPrint(paste("ci.summary.table <- summary.ci(ci=ci, res=res, event=", j, point, ")", sep="")) } else { # doItAndPrint(paste("ci.summary.table <- rbind(ci.summary.table, summary.ci(ci=ci, res=res, event=", j, point, xscale2, "))", sep="")) doItAndPrint(paste("ci.summary.table <- rbind(ci.summary.table, summary.ci(ci=ci, res=res, event=", j, point, "))", sep="")) } } } else { # doItAndPrint(paste("ci.summary.table <- summary.ci(ci=ci, res=res, event=", plotline, point, xscale2, ")", sep="" doItAndPrint(paste("ci.summary.table <- summary.ci(ci=ci, res=res, event=", plotline, point, ")", sep="" )) } } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} doItAndPrint(paste("compevents <- levels(factor(", subdataSet, "$", event, "))", sep="")) doItAndPrint("nevents <- length(compevents)") doItAndPrint('if (compevents[1]=="0") {compevents <- compevents[2:nevents]; nevents <- nevents - 1}') if (plotline==0){ if(eval(parse(text=paste("length(levels(factor(", subdataSet, "$", event, "[", subdataSet, "$", event, ">0])))", sep="")))==1){line <- paste("col=1, lty=1, ", par.lwd, sep="")} if (atrisk==0){ # doItAndPrint(paste('plot(ci, fun="event", bty="l", conf.int=FALSE, ', line, xlim, ylim, xlabel, ylabel, censor, xscale, ")", sep="")) if (nevent==1) {doItAndPrint(paste('plot(ci, fun="event", bty="l", conf.int=FALSE, ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) } else {doItAndPrint(paste('plot(ci[,2:', nevent+1, '], bty="l", conf.int=FALSE, ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) #for survival ver. 2.44-1.1 } } else { doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + 1 + 0.5") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # doItAndPrint(paste('plot(ci, fun="event", bty="l", conf.int=FALSE, ', line, xlim, ylim, xlabel, ylabel, censor, xscale, ")", sep="")) if (nevent==1) {doItAndPrint(paste('plot(ci, fun="event", bty="l", conf.int=FALSE, ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) } else {doItAndPrint(paste('plot(ci[,2:', nevent+1, '], bty="l", conf.int=FALSE, ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) #for survival ver. 2.44-1.1 } doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(ci, xticks", xscale2, ")", sep="")) if (nevent==1){doItAndPrint("n.atrisk <- nrisk(ci, xticks)")} else {doItAndPrint("n.atrisk <- nrisk(ci[,1], xticks)")} doItAndPrint("axis(1, at = xticks, labels = n.atrisk, line = 3, tick = FALSE)") doItAndPrint('title(xlab = "Number at risk", line = 3, adj = 0)') } doItAndPrint(paste("legend(", place, ", compevents, ", line, ', box.lty=0, title="Competing events")', sep="")) }else{ if (atrisk==0){ # doItAndPrint(paste("plot(ci[", plotline, '], fun="event", bty="l", lty=1:32, conf.int=FALSE', xlim, ylim, xlabel, ylabel, censor, xscale, ")", sep="")) if (nevent==1) {doItAndPrint(paste("plot(ci[", plotline, '], fun="event", bty="l", lty=1:32, conf.int=FALSE', xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) } else {doItAndPrint(paste("plot(ci[", plotline+1, '], bty="l", lty=1:32, conf.int=FALSE', xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) #survival package 2.44-1.1 } } else { doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + 1 + 0.5") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # doItAndPrint(paste("plot(ci[", plotline, '], fun="event", bty="l", lty=1:32, conf.int=FALSE', xlim, ylim, xlabel, ylabel, censor, xscale, ")", sep="")) if (nevent==1){doItAndPrint(paste("plot(ci[", plotline, '], fun="event", bty="l", lty=1:32, conf.int=FALSE', xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) } else {doItAndPrint(paste("plot(ci[", plotline+1, '], bty="l", lty=1:32, conf.int=FALSE', xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) #survival package 2.44-1.1 } doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(ci, xticks", xscale2, ")", sep="")) if (nevent==1){doItAndPrint("n.atrisk <- nrisk(ci, xticks)")}else{doItAndPrint("n.atrisk <- nrisk(ci[,1], xticks)")} doItAndPrint("axis(1, at = xticks, labels = n.atrisk, line = 3, tick = FALSE)") doItAndPrint('title(xlab = "Number at risk", line = 3, adj = 0)') } } } else { for (i in 1:nvar) { if(nevent==1){ command <- paste("ci <- survfit(Surv((", timetoevent, "/", xscale, "), ", event, ">0)~", group[i], ", data=", dataSet, subset, ', conf.type="log-log")', sep="") #Error message appears when etype option is chosen and there is only single group with only 1 event type. doItAndPrint(command) doItAndPrint("if(is.null(ci$surv) & is.null(ci$prev)) ci$surv <- 1-ci$pstate") plotline <- 0 doItAndPrint("ci$surv <- 1-ci$surv") doItAndPrint("tempCI <- 1-ci$lower") doItAndPrint("ci$lower <- 1-ci$upper") doItAndPrint("ci$upper <- tempCI") doItAndPrint("summary(ci)") #To show cumulative incidence, substract from 1, and the add 1 for plot(). doItAndPrint("ci$surv <- 1-ci$surv") doItAndPrint("tempCI <- 1-ci$lower") doItAndPrint("ci$lower <- 1-ci$upper") doItAndPrint("ci$upper <- tempCI") command <- paste("res <- with(", dataSet, ", cuminc((", timetoevent, "/", xscale, "), ", event, ", ", group[i], ", cencode=0", subset, ", na.action = na.omit))", sep="") doItAndPrint(command) } else { # command <- paste("ci <- survfit(Surv(", timetoevent, ", ", event, ">0)~", group[i], ", data=", dataSet, subset, ", etype=", event, ")", sep="") command <- paste("ci <- survfit(Surv((", timetoevent, "/", xscale, '), DummyEventForCI, type="mstate")~', group[i], ", data=", dataSet, subset, ', conf.type="log-log")', sep="") doItAndPrint(command) doItAndPrint("if(is.null(ci$surv) & is.null(ci$prev)) ci$surv <- 1-ci$pstate") command <- paste("res <- with(", dataSet, ", cuminc((", timetoevent, "/", xscale, "), ", event, ", ", group[i], ", cencode=0", subset, ", na.action = na.omit))", sep="") doItAndPrint(command) doItAndPrint("print.ci.summary(ci=ci)") } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} doItAndPrint(paste("compevents <- levels(factor(", subdataSet, "$", event, "))", sep="")) doItAndPrint("nevents <- length(compevents)") doItAndPrint('if (compevents[1]=="0") {compevents <- compevents[2:nevents]; nevents <- nevents - 1}') doItAndPrint(paste('len <- nchar("', group[i], '")', sep="")) doItAndPrint("groups <- substring(names(ci$strata), len+2)") doItAndPrint("ngroups <- length(groups)") if(plotline==0){ doItAndPrint('k <- 1; l <- 1; legend <- ""') doItAndPrint('for(i in 1:nevents){for(j in 1:ngroups){legend[k] <- paste(groups[j], ":", compevents[i]); ifelse(k==1,legendline <- (i-1)*ngroups+j, legendline <- c(legendline, (i-1)*ngroups+j)); k <- k+1 }}') }else{ # doItAndPrint(paste("legend <- levels(factor(", subdataSet, "$", group[i], "))", sep="")) doItAndPrint("legend <- groups") } if (line==paste("col=1, lty=1, ", par.lwd, ":8", sep="") & par.lwd!="lwd=1") doItAndPrint(paste("legendline <- legendline + ", as.integer(substring(par.lwd, nchar(par.lwd),nchar(par.lwd))) - 1, sep="")) if (plotline==0){ if (line==paste("col=legendline, lty=1, ", par.lwd, sep="")) line <- paste("col=1:32, lty=1, ", par.lwd, sep="") #line cvariable changed for legend again changed for plot() if (line==paste("col=1, lty=legendline, ", par.lwd, sep="")) line <- paste("col=1, lty=1:32, ", par.lwd, sep="") if (line=="col=1, lty=1, lwd=legendline") line <- paste("col=1, lty=1, ", par.lwd, ":8", sep="") if (atrisk==0){ # doItAndPrint(paste('plot(ci, fun="event", bty="l", ', line, xlim, ylim, xlabel, ylabel, censor, xscale, ")", sep="")) if (nevent==1) {doItAndPrint(paste('plot(ci, fun="event", bty="l", ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) } else {doItAndPrint(paste('plot(ci[,2:', nevent+1, '], bty="l", ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) #for survival ver. 2.44-1.1 } # doItAndPrint(paste("legend (", place, ", legend, ", line, ', box.lty=0, title="', strata3, group[i], '")', sep="")) }else{ doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + length(ci$strata) + 0.5") doItAndPrint("mar[2] <- mar[2] + 2") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # doItAndPrint(paste('plot(ci, fun="event", bty="l", ', line, xlim, ylim, xlabel, ylabel, censor, xscale, ")", sep="")) if (nevent==1) {doItAndPrint(paste('plot(ci, fun="event", bty="l", ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) } else {doItAndPrint(paste('plot(ci[,2:', nevent+1, '], bty="l", ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) #for survival ver. 2.44-1.1 } doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(ci, xticks", xscale2, ")", sep="")) if (nevent==1){doItAndPrint("n.atrisk <- nrisk(ci, xticks)")}else{doItAndPrint("n.atrisk <- nrisk(ci[,1], xticks)")} doItAndPrint("for (i in 1:length(ci$strata)){axis(1, at = xticks, labels = n.atrisk[i,], line=3+i, tick = FALSE)}") doItAndPrint(paste("for (i in 1:length(ci$strata)){mtext(groups[i], side=1, at=-(xticks[2]-xticks[1])/2, line=4+i, cex=", par.cex, ")}", sep="")) doItAndPrint('title(xlab = "Number at risk", line = 3.5, adj = 0)') # doItAndPrint(paste("legend (", place, ", legend, ", line, ', box.lty=0, title="', strata3, group[i], '")', sep="")) } if (line==paste("col=1:32, lty=1, ", par.lwd, sep="")) line <- paste("col=legendline, lty=1, ", par.lwd, sep="") if (line==paste("col=1, lty=1:32, ", par.lwd, sep="")) line <- paste("col=1, lty=legendline, ", par.lwd, sep="") if (line==paste("col=1, lty=1, ", par.lwd, ":8", sep="")) line <- "col=1, lty=1, lwd=legendline" doItAndPrint(paste("legend(", place, ", legend, box.lty=0, ", line, ', title="', group[i], ' : Competing events")', sep="")) }else{ if (atrisk==0){ # doItAndPrint(paste("plot(ci[,", plotline, '], fun="event", bty="l", ', line, xlim, ylim, xlabel, ylabel, censor, xscale, ")", sep="")) if (nevent==1) {doItAndPrint(paste("plot(ci[,", plotline, '], fun="event", bty="l", ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) } else {doItAndPrint(paste("plot(ci[,", plotline+1, '], bty="l", ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) #for survival ver. 2.44-1.1 } # doItAndPrint(paste("legend (", place, ", legend, ", line, ', box.lty=0, title="', strata3, group[i], '")', sep="")) }else{ doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + length(ci$strata) + 0.5") doItAndPrint("mar[2] <- mar[2] + 2") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # doItAndPrint(paste("plot(ci[,", plotline, '], fun="event", bty="l", ', line, xlim, ylim, xlabel, ylabel, censor, xscale, ")", sep="")) if (nevent==1){doItAndPrint(paste("plot(ci[,", plotline, '], fun="event", bty="l", ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) } else {doItAndPrint(paste("plot(ci[,", plotline+1, '], bty="l", ', line, xlim, ylim, ypercent1, xlabel, ylabel, censor, ")", sep="")) #for survival ver. 2.44-1.1 } doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(ci, xticks", xscale2, ")", sep="")) if (nevent==1){doItAndPrint(paste("n.atrisk <- nrisk(ci, xticks", ")", sep=""))}else{doItAndPrint(paste("n.atrisk <- nrisk(ci[,1], xticks", ")", sep=""))} doItAndPrint("for (i in 1:length(ci$strata)){axis(1, at = xticks, labels = n.atrisk[i,], line=3+i, tick = FALSE)}") doItAndPrint(paste("for (i in 1:length(ci$strata)){mtext(groups[i], side=1, at=-(xticks[2]-xticks[1])/2, line=4+i, cex=", par.cex, ")}", sep="")) doItAndPrint('title(xlab = "Number at risk", line = 3.5, adj = 0)') # doItAndPrint(paste("legend (", place, ", legend, ", line, ', box.lty=0, title="', strata3, group[i], '")', sep="")) } doItAndPrint(paste("legend(", place, ", legend, box.lty=0, ", line, ', title="', group[i], '")', sep="")) } doItAndPrint("res$Tests") if(nevent>1){ if(plotline==0){ for (j in 1:nevent){ # if(i==1 & j==1) {doItAndPrint(paste("ci.summary.table <- summary.ci(ci=ci, res=res, event=", j, point, xscale2, ")", sep="")) if(i==1 & j==1) {doItAndPrint(paste("ci.summary.table <- summary.ci(ci=ci, res=res, event=", j, point, ")", sep="")) } else { # doItAndPrint(paste("ci.summary.table <- rbind(ci.summary.table, summary.ci(ci=ci, res=res, event=", j, point, xscale2, "))", sep="")) doItAndPrint(paste("ci.summary.table <- rbind(ci.summary.table, summary.ci(ci=ci, res=res, event=", j, point,"))", sep="")) } } } else { if (i == 1){ # if(plotline>0) doItAndPrint(paste("ci.summary.table <- summary.ci(ci=ci, res=res, event=", plotline, point, xscale2, ")", sep="")) if(plotline>0) doItAndPrint(paste("ci.summary.table <- summary.ci(ci=ci, res=res, event=", plotline, point, ")", sep="")) } else { # if(plotline>0) doItAndPrint(paste("ci.summary.table <- rbind(ci.summary.table, summary.ci(ci=ci, res=res, event=", plotline, point, xscale2, "))", sep="")) if(plotline>0) doItAndPrint(paste("ci.summary.table <- rbind(ci.summary.table, summary.ci(ci=ci, res=res, event=", plotline, point, "))", sep="")) } } } } if(nvar==1 && plotline>0 && posthoc!=""){ command <- paste("pairwise.gray.test(", subdataSet, "$", timetoevent, ", ", subdataSet, "$", event, ", ", subdataSet, "$", group[i], ', "', dataSet, '", p.adjust.method="', posthoc, '", endpoint=', plotline, ")", sep="") doItAndPrint(command) } # doItAndPrint("remove(res)") } # if(plotline>0){ if(nevent>1) doItAndPrint("ci.summary.table") # doItAndPrint("remove(ci.summary.table)") # } # doItAndPrint("remove(ci)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="cuminc", apply="StatMedCumInc", reset="StatMedCumInc") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(variables2Frame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="w") # tkgrid(getFrame(groupBox), labelRcmdr(variables2Frame, text=" "), getFrame(strataBox), sticky="nw") tkgrid(getFrame(groupBox), labelRcmdr(variables2Frame, text=" "), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(lineFrame, labelRcmdr(plotoptionFrame, text=" "), placeFrame, labelRcmdr(plotoptionFrame, text=" "), xscaleFrame, labelRcmdr(plotoptionFrame, text=" "), posthocFrame, sticky="w") tkgrid(plotoptionFrame, sticky="nw") # tkgrid(color, sticky="w") tkgrid(censor, labelRcmdr(plotoption2Frame, text=" "), atrisk, labelRcmdr(plotoption2Frame, text=" "), ypercent, sticky="w") tkgrid(plotoption2Frame, sticky="nw") # tkgrid(labelRcmdr(plotoption2Frame, text=""), censor, atrisk, sticky="w") # tkgrid(plotoption2Frame, sticky="nw") tkgrid(labelRcmdr(ploteventFrame, text=gettextRcmdr("Code of event to show cumulative incidence rate")), ploteventField, sticky = "w") tkgrid(ploteventFrame, sticky="w") tkgrid(labelRcmdr(pointFrame, text=gettextRcmdr("Time point to show survival rate")), pointField, sticky = "w") tkgrid(pointFrame, sticky="w") tkgrid(labelRcmdr(xlimFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimField, sticky = "w") # tkgrid(xlimFrame, sticky="w") tkgrid(labelRcmdr(ylimFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimField, sticky = "w") # tkgrid(ylimFrame, sticky="w") tkgrid(xlimFrame, labelRcmdr(axis2Frame, text=" "), ylimFrame, sticky="w") tkgrid(labelRcmdr(xlabelFrame, text=gettextRcmdr("X axis label")), xlabelField, sticky = "w") tkgrid(labelRcmdr(ylabelFrame, text=gettextRcmdr("Y axis label")), ylabelField, sticky = "w") tkgrid(xlabelFrame, labelRcmdr(axis2Frame, text=" "), ylabelFrame, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("Code of event to show cumulative incidence rate")), ploteventEntry, sticky="w") # tkgrid.configure(ploteventEntry, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("Time point to show cumulative incidence rate")), pointEntry, sticky="w") # tkgrid.configure(pointEntry, sticky="w") # tkgrid(labelRcmdr(axisFrame, text=gettextRcmdr("Cumulative incidence rate shown only when one event specified"), fg="blue"), sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimEntry, sticky="w") # tkgrid.configure(xlimEntry, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimEntry, sticky="w") # tkgrid.configure(ylimEntry, sticky="w") tkgrid(axisFrame, sticky="w") tkgrid(axis2Frame, sticky="w") StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedStackCumInc <- function(){ defaults <- list(event = "", timetoevent = "", group = "", atrisk = 1, xlim = "<auto>", ylim = "<auto>", xlabel = "<auto>", ylabel = "<auto>", ypercent = 0, subset = "") dialog.values <- getDialog("StatMedStackCumInc", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Stacked cumulative incidences")) variablesFrame <- tkframe(top) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1,2,3...) (pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$event, "all")) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$timetoevent, "all")) variables2Frame <- tkframe(top) groupBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=6, initialSelection=varPosn(dialog.values$group, "all")) plotoptionFrame <- tkframe(top) checkBoxes(window=plotoptionFrame, frame="atrisk", boxes="atrisk", initialValues=dialog.values$atrisk,labels=gettextRcmdr("Show number at risk"), title=gettextRcmdr("Options")) checkBoxes(window=plotoptionFrame, frame="ypercent", boxes="ypercent", initialValues=dialog.values$ypercent,labels=gettextRcmdr("Y axis with percentage"), title=gettextRcmdr("Options")) # checkBoxes(window=plotoptionFrame, frame="atrisk", boxes=c("atrisk"),initialValues=c(0),labels=gettextRcmdr(c("Show number at risk"))) plotoption2Frame <- tkframe(top) xlimFrame <- tkframe(plotoption2Frame) xlimVariable <- tclVar(dialog.values$xlim) xlimField <- ttkentry(plotoption2Frame, width="20", textvariable=xlimVariable) ylimFrame <- tkframe(plotoption2Frame) ylimVariable <- tclVar(dialog.values$ylim) ylimField <- ttkentry(plotoption2Frame, width="20", textvariable=ylimVariable) xlabelFrame <- tkframe(plotoption2Frame) xlabelVariable <- tclVar(dialog.values$xlabel) xlabelField <- ttkentry(plotoption2Frame, width="20", textvariable=xlabelVariable) ylabelFrame <- tkframe(plotoption2Frame) ylabelVariable <- tclVar(dialog.values$ylabel) ylabelField <- ttkentry(plotoption2Frame, width="20", textvariable=ylabelVariable) # xlim <- tclVar("<auto>") # xlimEntry <- ttkentry(plotoptionFrame, width="20", textvariable=xlim) # ylim <- tclVar("<auto>") # ylimEntry <- ttkentry(plotoptionFrame, width="20", textvariable=ylim) onOK <- function(){ logger(paste("#####", gettextRcmdr("Stacked cumulative incidences"), "#####", sep="")) event <- getSelection(eventBox) timetoevent <- getSelection(timetoeventBox) group <- getSelection(groupBox) dataSet <- activeDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subdataSet <- dataSet subset <- "" } else{ subdataSet <- paste("subset(", dataSet, ", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } atrisk <- tclvalue(atriskVariable) ypercent <- tclvalue(ypercentVariable) xlim <- tclvalue(xlimVariable) ylim <- tclvalue(ylimVariable) if (xlim == "<auto>") { xlim <- "" } else { xlim <- paste(", xlim=c(", xlim, ")", sep="") } if (ylim == "<auto>") { ylim <- ", ylim=c(0, 1)" } else { ylim <- paste(", ylim=c(", ylim, ")", sep="") } xlabel <- tclvalue(xlabelVariable) ylabel <- tclvalue(ylabelVariable) if (xlabel == "<auto>") { xlabel <- paste(', xlab="', timetoevent, '"', sep="") } else { xlabel <- paste(', xlab="', xlabel, '"', sep="") } if (ylabel == "<auto>") { ylabel <- ', ylab="Probability"' } else { ylabel <- paste(', ylab="', ylabel, '"', sep="") } putDialog("StatMedStackCumInc", list(event = event, timetoevent = timetoevent, group = group, atrisk = atrisk, ypercent = ypercent, xlim = tclvalue(xlimVariable), ylim = tclvalue(ylimVariable), xlabel = tclvalue(xlabelVariable), ylabel = tclvalue(ylabelVariable), subset = tclvalue(subsetVariable))) if (length(event) != 1) { errorCondition(recall=StatMedStackCumInc, message=gettextRcmdr("Pick one status indicator (censor=0, event=1,2,3...)")) return() } if (length(timetoevent) != 1) { errorCondition(recall=StatMedStackCumInc, message=gettextRcmdr("Pick one time-to-event variable")) return() } closeDialog() Library("survival") Library("cmprsk") # library(survival) # library(cmprsk) nvar <- length(group) if (nvar == 0){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} doItAndPrint(paste("stackcuminc(", subdataSet, "$", timetoevent, ", ", subdataSet, "$", event, xlim, ylim, xlabel, ylabel, ", atrisk=", atrisk, ", ypercent=", ypercent, ")", sep="")) } else { groups <- eval(parse(text=paste("levels(factor(", subdataSet, "$", group, "))", sep=""))) for (i in groups){ sub2dataSet <- paste("subset(", subdataSet, ", ", group, "=='", i, "')", sep="") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} doItAndPrint(paste("stackcuminc(", sub2dataSet, "$", timetoevent, ", ", sub2dataSet, "$", event, xlim, ylim, xlabel, ylabel, ", atrisk=", atrisk, ", ypercent=", ypercent, ", main='", group, " = ", i, "')", sep="")) } } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="cuminc", apply="StatMedStackCumInc", reset="StatMedStackCumInc") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(groupBox), labelRcmdr(variables2Frame, text=" "), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(atrisk, labelRcmdr(plotoptionFrame, text=" "), ypercent, sticky="w") tkgrid(plotoptionFrame, sticky="nw") tkgrid(labelRcmdr(xlimFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimField, sticky = "w") tkgrid(labelRcmdr(ylimFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimField, sticky = "w") tkgrid(xlimFrame, labelRcmdr(plotoption2Frame, text=" "), ylimFrame, sticky="w") tkgrid(labelRcmdr(xlabelFrame, text=gettextRcmdr("X axis label")), xlabelField, sticky = "w") tkgrid(labelRcmdr(ylabelFrame, text=gettextRcmdr("Y axis label")), ylabelField, sticky = "w") tkgrid(xlabelFrame, labelRcmdr(plotoption2Frame, text=" "), ylabelFrame, sticky="w") tkgrid(plotoption2Frame, sticky="nw") # tkgrid(tklabel(plotoptionFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimEntry, sticky="w") # tkgrid.configure(xlimEntry, sticky="w") # tkgrid(tklabel(plotoptionFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimEntry, sticky="w") # tkgrid.configure(ylimEntry, sticky="w") StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedCrr <- function(){ defaults <- list(event = "", timetoevent = "", group = "", fcode = 1, wald = 0, stepwise1 = 0, stepwise2 = 0, stepwise3 = 0, subset = "") dialog.values <- getDialog("StatMedCrr", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Fine-Gray proportional hazard regression for competing events")) variablesFrame <- tkframe(top) fcodeFrame <- tkframe(top) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1,2,3...) (pick one)"), listHeight=10, initialSelection=varPosn(dialog.values$event, "all")) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=10, initialSelection=varPosn(dialog.values$timetoevent, "all")) groupBox <- variableListBox(top, Variables(), selectmode="multiple", title=gettextRcmdr("Explanatory (non-character) variables (pick one or more)"), listHeight=10, initialSelection=varPosn(dialog.values$group, "all")) fcodeFrame <- tkframe(top) fcodeVariable <- tclVar(dialog.values$fcode) fcodeField <- ttkentry(fcodeFrame, width="20", textvariable=fcodeVariable) # fcode <- tclVar("1") # fcodeEntry <- ttkentry(fcodeFrame, width="10", textvariable=fcode) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("wald", "stepwise1", "stepwise2", "stepwise3"), initialValues=c(dialog.values$wald, dialog.values$stepwise1, dialog.values$stepwise2, dialog.values$stepwise3),labels=gettextRcmdr(c("Wald test for overall p-value for factors with >2 levels", "Stepwise selection based on AIC", "Stepwise selection based on BIC", "Stepwise selection based on p-value"))) # waldVariable <- tclVar("0") # waldCheckBox <- tkcheckbutton(optionsFrame, variable=waldVariable) # stepwise1Variable <- tclVar("0") # stepwise1CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise1Variable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Fine-Gray proportional hazard regression for competing events"), "#####", sep="")) event <- getSelection(eventBox) timetoevent <- getSelection(timetoeventBox) group <- getSelection(groupBox) fcode <- tclvalue(fcodeVariable) wald <- tclvalue(waldVariable) stepwise1 <- tclvalue(stepwise1Variable) stepwise2 <- tclvalue(stepwise2Variable) stepwise3 <- tclvalue(stepwise3Variable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" } else{ subset <- paste(", subset=", subset, sep="") } putDialog("StatMedCrr", list(event = event, timetoevent = timetoevent, group = group, fcode = fcode, wald = wald, stepwise1 = stepwise1, stepwise2 = stepwise2, stepwise3 = stepwise3, subset = tclvalue(subsetVariable))) if (length(event) != 1) { errorCondition(recall=StatMedCrr, ) message=gettextRcmdr("Pick one status indicator (censor=0, event=1,2,3...)") return() } if (length(timetoevent) != 1) { errorCondition(recall=StatMedCrr, message=gettextRcmdr("Pick one time-to-event variable")) return() } if (length(group) == 0) { errorCondition(recall=StatMedCrr, message=gettextRcmdr("Pick at least one explanatory variable")) return() } if (length(fcode) == 0) { errorCondition(recall=StatMedCrr, message=gettextRcmdr("Specify one event of interest")) return() } closeDialog() Library("survival") Library("cmprsk") Library("aod") # library(survival) # library(cmprsk) dataSet <- activeDataSet() nvar <- length(group) command <- paste("cov.matrix <- cbind(", group[1], "=", dataSet, "$", group[1], sep="") if (nvar >= 2){ for (i in 2:nvar) { command <- paste(command, ", ", group[i], "=", dataSet, "$", group[i], sep="") } } command <- paste(command, ")", sep="") doItAndPrint(command) doItAndPrint("crr <- NULL") command2 <- paste("crr <- with(", dataSet, ", crr(", timetoevent, ", ", event, ", cov.matrix, failcode=", fcode, ", cencode=0", subset, ", na.action = na.omit))", sep="") doItAndPrint(command2) doItAndPrint("summary(crr)") doItAndPrint("crr.table <- NULL") if(eval(parse(text="length(summary(crr)$coef[,1])"))==1){ doItAndPrint("crr.table <- signif(cbind(t(summary(crr)$conf.int[,c(1,3,4)]), p.value=summary(crr)$coef[,5]), digits=4)") doItAndPrint(paste('rownames(crr.table) <- "', group[1], '"', sep="")) doItAndPrint('colnames(crr.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } else { doItAndPrint("crr.table <- signif(cbind(summary(crr)$conf.int[,c(1,3,4)], summary(crr)$coef[,5]), digits=4)") doItAndPrint('colnames(crr.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } # doItAndPrint("crr.table <- signif(crr.table, digits=3)") doItAndPrint("crr.table") if (wald==1) doItAndPrint("waldtest.crr(crr, rownames(crr.table))") if (stepwise1 == 1 | stepwise2 == 1 | stepwise3 == 1){ command <- paste("TempDF <- with(", ActiveDataSet(), ", ", ActiveDataSet(), "[complete.cases(", paste(group, collapse=", "), "),])", sep="") doItAndPrint(command) command <- paste('cov <- c("', group[1], '"', sep="") if (nvar >= 2){ for (i in 2:nvar) { command <- paste(command, ', "', group[i], '"', sep="") } } command <- paste(command, ')', sep="") doItAndPrint(command) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" }else{ subset <- paste(", subset='", trim.blanks(subset), "'", sep="") } } if (stepwise1 == 1){ doItAndPrint(paste('step.AIC.crr(crr, cov, "TempDF", BIC=0, waldtest=', wald, subset, ")", sep="")) } if (stepwise2 == 1){ doItAndPrint(paste('step.AIC.crr(crr, cov, "TempDF", BIC=1, waldtest=', wald, subset, ")", sep="")) } if (stepwise3 == 1){ doItAndPrint(paste('step.p.crr(crr, cov, "TempDF", wald=', wald, subset, ")", sep="")) } # doItAndPrint("remove(crr)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="crr", apply="StatMedCrr", reset="StatMedCrr") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(fcodeFrame, text=gettextRcmdr("Input code of event of interest"), fg="blue"), fcodeField, sticky = "w") tkgrid(fcodeFrame, sticky="w") # tkgrid(tklabel(fcodeFrame, text=gettextRcmdr("Input code of event of interest"), fg="blue"), fcodeEntry, sticky="w") # tkgrid.configure(fcodeEntry, sticky="w") # tkgrid(fcodeFrame, sticky="w") tkgrid(getFrame(groupBox), sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr("Dummy variables required for factors of more than 2 groups"), fg="blue"), sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Wald test for overall p-value for factors with >2 levels")), waldCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on p-value")), stepwise1CheckBox, sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedAdjustedCumInc <- function(){ defaults <- list(event = "", timetoevent = "", group = "", fcode = 1, adjust = "", line = "color", place = "topright", xscale = "1", censor = 1, atrisk = 1, xlim = "<auto>", ylim = "<auto>", xlabel = "<auto>", ylabel = "<auto>", ypercent = 0, subset = "") dialog.values <- getDialog("StatMedAdjustedCumInc", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Adjusted cumulative incidence curve")) variablesFrame <- tkframe(top) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1,2,3...) (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$event, "all")) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$timetoevent, "all")) variables2Frame <- tkframe(top) groupBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=8, initialSelection=varPosn(dialog.values$group, "all")) adjustBox <- variableListBox(variables2Frame, Variables(), selectmode="multiple", title=gettextRcmdr("Variables for adjustment (pick at least one)"), listHeight=8, initialSelection=varPosn(dialog.values$adjust, "all")) fcodeFrame <- tkframe(top) fcodeVariable <- tclVar(dialog.values$fcode) fcodeField <- ttkentry(fcodeFrame, width="20", textvariable=fcodeVariable) plotoptionFrame <- tkframe(top) radioButtons(plotoptionFrame, name="line", buttons=c("color", "type", "width"), values=c("color", "type", "width"), initialValue=dialog.values$line, labels=gettextRcmdr(c("Color", "Line type", "Line width")), title=gettextRcmdr("Line discrimination")) radioButtons(plotoptionFrame, name="place", buttons=c("topright", "bottom", "mouse"), values=c("topright", "bottom", "mouse"), initialValue=dialog.values$place, labels=gettextRcmdr(c("Upper right", "Bottom", "Mouse click")), title=gettextRcmdr("Legend")) radioButtons(plotoptionFrame, name="xscale", buttons=c("day", "daytomonth", "daytoyear", "monthtoyear"), values=c("1", "30.4375", "365.25", "12"), initialValue=dialog.values$xscale, labels=gettextRcmdr(c("As is", "Day to month", "Day to year", "Month to year")), title=gettextRcmdr("X axis")) plotoption2Frame <- tkframe(top) checkBoxes(window=plotoption2Frame, frame="censor", boxes=c("censor"),initialValues=dialog.values$censor,labels=gettextRcmdr(c("Show censoring marks")), title=gettextRcmdr("Options")) checkBoxes(window=plotoption2Frame, frame="atrisk", boxes=c("atrisk"),initialValues=dialog.values$atrisk,labels=gettextRcmdr(c("Show number at risk")), title=gettextRcmdr(" ")) checkBoxes(window=plotoption2Frame, frame="ypercent", boxes=c("ypercent"), initialValues=c(dialog.values$ypercent),labels=gettextRcmdr(c("Y axis with percentage")), title=gettextRcmdr(" ")) axisFrame <- tkframe(top) xlimFrame <- tkframe(axisFrame) xlimVariable <- tclVar(dialog.values$xlim) xlimField <- ttkentry(axisFrame, width="20", textvariable=xlimVariable) ylimFrame <- tkframe(axisFrame) ylimVariable <- tclVar(dialog.values$ylim) ylimField <- ttkentry(axisFrame, width="20", textvariable=ylimVariable) xlabelFrame <- tkframe(axisFrame) xlabelVariable <- tclVar(dialog.values$xlabel) xlabelField <- ttkentry(axisFrame, width="20", textvariable=xlabelVariable) ylabelFrame <- tkframe(axisFrame) ylabelVariable <- tclVar(dialog.values$ylabel) ylabelField <- ttkentry(axisFrame, width="20", textvariable=ylabelVariable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Adjusted cumulative incidence curve"), "#####", sep="")) event <- getSelection(eventBox) timetoevent <- getSelection(timetoeventBox) group <- getSelection(groupBox) fcode <- tclvalue(fcodeVariable) adjust <- getSelection(adjustBox) dataSet <- activeDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subdataSet <- dataSet naexcludeSubdataSet <- paste("subset(", dataSet, ", ", sep="") } else{ subdataSet <- paste("subset(", dataSet, ", ", subset, ")", sep="") naexcludeSubdataSet <- paste("subset(", dataSet, ", (", subset, ") & ", sep="") } line <- tclvalue(lineVariable) par.lwd <- get("par.lwd", envir=.GlobalEnv) if (line=="color") line <- paste("col=1:32, lty=1, ", par.lwd, ", ", sep="") if (line=="type") line <- paste("col=1, lty=1:32, ", par.lwd, ", ", sep="") if (line=="width") line <- paste("col=1, lty=1, ", par.lwd, ":8, ", sep="") par.cex <- get("par.cex", envir=.GlobalEnv) if(length(group)==0){line <- paste("col=1, lty=1, ", par.lwd, ", ", sep="")} place <- tclvalue(placeVariable) if(place=="mouse"){ place <- "locator(1)" }else if (place=="topright"){ place <- '"topright"' }else{ place <- '"bottom", horiz=TRUE' } censor <- tclvalue(censorVariable) atrisk <- tclvalue(atriskVariable) ypercent <- tclvalue(ypercentVariable) xscale <- tclvalue(xscaleVariable) # xscale2 <- "" # if (xscale!=""){ # xscale2 <- paste(" * ", xscale, sep="") # xscale <- paste(", xscale=", xscale, sep="") # } xlim <- tclvalue(xlimVariable) ylim <- tclvalue(ylimVariable) xlabel <- tclvalue(xlabelVariable) ylabel <- tclvalue(ylabelVariable) if (xlabel == "<auto>") { xlabel <- paste(', xlab="', timetoevent, '"', sep="") } else { xlabel <- paste(', xlab="', xlabel, '"', sep="") } if (ylabel == "<auto>") { ylabel <- ', ylab="Probability"' } else { ylabel <- paste(', ylab="', ylabel, '"', sep="") } if (ypercent==0){ ypercent1 <- "" } else { ypercent1 <- ", yscale=100" } if (ypercent==1){ ylabel <- paste(substr(ylabel, 1, nchar(ylabel)-1), ' (%)"', sep="") } if (xlim == "<auto>") { xlim <- "" } else { xlim <- paste(", xlim=c(", xlim, ")", sep="") } if (ylim == "<auto>") { if (ypercent==0){ ylim <- ", ylim=c(0, 1)" } else { # ylim <- ", ylim=c(0, 100)" ylim <- ", ylim=c(0, 1)" #changed according to the change in survival 3.1-8 } } else { if (ypercent==0){ ylim <- paste(", ylim=c(", ylim, ")", sep="") } else { # ylim <- paste(", ylim=c(", ylim, ")*100", sep="") ylim <- paste(", ylim=c(", ylim, ")", sep="") #changed according to the change in survival 3.1-8 } } if (censor==0){ censor <- ", mark.time=FALSE" }else{ censor <- ", mark.time=TRUE" } putDialog("StatMedAdjustedCumInc", list(event = event, timetoevent = timetoevent, group = group, fcode = fcode, adjust = adjust, line = tclvalue(lineVariable), place = tclvalue(placeVariable), xscale = tclvalue(xscaleVariable), censor = tclvalue(censorVariable), atrisk = atrisk, ypercent = ypercent, xlim = tclvalue(xlimVariable), ylim = tclvalue(ylimVariable), xlabel = tclvalue(xlabelVariable), ylabel = tclvalue(ylabelVariable), subset = tclvalue(subsetVariable))) if (length(event) != 1) { errorCondition(recall=StatMedAdjustedCumInc, message=gettextRcmdr("Pick one status indicator (censor=0, event=1)")) return() } if (length(timetoevent) != 1) { errorCondition(recall=StatMedAdjustedCumInc, message=gettextRcmdr("Pick one time-to-event variable")) return() } if (length(adjust) == 0) { errorCondition(recall=StatMedAdjustedCumInc, message=gettextRcmdr("Pick at least one variable for adjustment.")) return() } if (length(fcode) == 0) { errorCondition(recall=StatMedAdjustedCumInc, message=gettextRcmdr("Specify one event of interest")) return() } closeDialog() Library("survival") naexcludeSubdataSet <- paste(naexcludeSubdataSet, "(is.na(", timetoevent, ")==F & is.na(", event, ")==F & is.na(", group, ")==F", sep="") # naexcludeSubdataSet <- paste(naexcludeSubdataSet, "(is.na(", adjust[1], ")==F", sep="") factor <- adjust[1] if(length(adjust)>=1) naexcludeSubdataSet <- paste(naexcludeSubdataSet, " & is.na(", adjust[1], ")==F", sep="") if(length(adjust)>=2){ for (i in 2:length(adjust)){ factor <- paste(factor, " + ", adjust[i], sep="") naexcludeSubdataSet <- paste(naexcludeSubdataSet, " & is.na(", adjust[i], ")==F", sep="") } } factor2 <- factor naexcludeSubdataSet <- paste(naexcludeSubdataSet, "))", sep="") if (length(group)==1) factor2 <- paste(factor, " + strata(", group, ")", sep="") # command <- paste("coxmodel <- coxph(Surv((", timetoevent, "/", xscale, "), ", event, "==1)~ ", factor2, ", data=", subdataSet, ', method="breslow")', sep="") # use naexcludeSubdataset for rmean.table.adjusted() function. Can be replaced with complete.case() function. command = paste("Temp.CI <- finegray(Surv(", timetoevent, ", as.factor(", event, "))~., data=", naexcludeSubdataSet, ', etype="', fcode, '")', sep="") doItAndPrint(command) command <- paste("coxmodel <- coxph(Surv((fgstart / ", xscale, "), fgstop, fgstatus) ~ ", factor2, ', data=Temp.CI, weight=fgwt, method="breslow")', sep="") doItAndPrint("coxmodel <- NULL") doItAndPrint(command) doItAndPrint("cox <- NULL") doItAndPrint('cox <- survfit(coxmodel, conf.type="log-log")') if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} if(length(group)==1){ check.type <- eval(parse(text=paste(subdataSet, "$", group, sep=""))) if(is.integer(check.type) | is.numeric(check.type)){ doItAndPrint(paste('len <- nchar("', group, '")', sep="")) doItAndPrint("group.levels <- substring(names(cox$strata[cox$strata>0]),len+2)") } else { doItAndPrint("group.levels <- names(cox$strata[cox$strata>0])") } } if(atrisk==1){ Library("cmprsk") command <- paste("ci <- survfit(Surv((", timetoevent, " / ", xscale, "), as.factor(", event, '), type="mstate") ~ ', group, ", data=", naexcludeSubdataSet, ', conf.type="log-log")', sep="") doItAndPrint(command) if(length(group)==0){ doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + 1 + 0.5") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, xlabel, ylabel, xscale, ")", sep="") command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, ypercent1, xlabel, ylabel, ', fun="event")', sep="") doItAndPrint(command3) doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(cox, xticks", xscale2, ")", sep="")) doItAndPrint("n.atrisk <- nrisk(ci[,1], xticks)") doItAndPrint("axis(1, at = xticks, labels = n.atrisk, line = 3, tick = FALSE)") doItAndPrint('title(xlab = "Number at risk", line = 3, adj = 0)') } else { doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + length(cox$strata) + 0.5") doItAndPrint("mar[2] <- mar[2] + 2") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") # command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, xlabel, ylabel, xscale, ")", sep="") command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, ypercent1, xlabel, ylabel, ', fun="event")', sep="") doItAndPrint(command3) doItAndPrint("xticks <- axTicks(1)") # doItAndPrint(paste("n.atrisk <- nrisk(cox, xticks", xscale2, ")", sep="")) doItAndPrint("n.atrisk <- nrisk(ci[,1], xticks)") doItAndPrint("for (i in 1:length(cox$strata)){axis(1, at = xticks, labels = n.atrisk[i,], line=3+i, tick = FALSE)}") # doItAndPrint(paste('#for (i in 1:length(cox$strata)){for (j in 1:(length(xticks)-1)) {axis(1, at=c(xticks[j]+(xticks[2]-xticks[1])/3, xticks[j+1]-+(xticks[2]-xticks[1])/3), labels=c(" ", " "), line=4.6+i, ', line2, "lwd.ticks=0, tick = TRUE)}}", sep="")) doItAndPrint(paste("for (i in 1:length(cox$strata)){mtext(group.levels[i], at=-(xticks[2]-xticks[1])/2, side=1, line=4+i, cex=", par.cex, ")}", sep="")) doItAndPrint('title(xlab = "Number at risk", line = 3.5, adj = 0)') # doItAndPrint(paste("legend (", place, ", legend, ", line, ' box.lty=0, title="', strata3, group[i], '")', sep="")) } } else { # command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, xlabel, ylabel, xscale, ")", sep="") command3 <- paste("plot(cox, ", line, 'bty="l"', censor, xlim, ylim, ypercent1, xlabel, ylabel, ', fun="event")', sep="") doItAndPrint(command3) } if(length(group)==1){ doItAndPrint(paste("legend(", place, ', group.levels, title="', group, '", ', line, "box.lty=0)", sep="")) } doItAndPrint(paste('title("Cumulative incidence curve adjusted for ', factor, '")', sep="")) doItAndPrint("res <- summary(cox)") doItAndPrint("res$surv <- 1 - res$surv") doItAndPrint("temp.u <- 1 - res$lower") doItAndPrint("res$lower <- 1 - res$upper") doItAndPrint("res$upper <- temp.u") doItAndPrint("res") # doItAndPrint("remove(cox)") # doItAndPrint("remove(coxmodel)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="coxph", model=TRUE, apply="StatMedAdjustedCumInc", reset="StatMedAdjustedCumInc") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(fcodeFrame, text=gettextRcmdr("Input code of event of interest"), fg="blue"), fcodeField, sticky = "w") tkgrid(fcodeFrame, sticky="w") tkgrid(labelRcmdr(variables2Frame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables"), fg="blue"), sticky="e") tkgrid(getFrame(groupBox), labelRcmdr(variables2Frame, text=" "), getFrame(adjustBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(lineFrame, labelRcmdr(plotoptionFrame, text=" "), placeFrame, labelRcmdr(plotoptionFrame, text=" "), xscaleFrame, sticky="w") tkgrid(plotoptionFrame, sticky="nw") tkgrid(censor, labelRcmdr(plotoption2Frame, text=" "), atrisk, labelRcmdr(plotoption2Frame, text=" "), ypercent, sticky="w") tkgrid(plotoption2Frame, sticky="nw") tkgrid(labelRcmdr(xlimFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimField, sticky = "w") # tkgrid(xlimFrame, sticky="w") tkgrid(labelRcmdr(ylimFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimField, sticky = "w") # tkgrid(ylimFrame, sticky="w") tkgrid(xlimFrame, labelRcmdr(axisFrame, text=" "), ylimFrame, sticky="w") tkgrid(labelRcmdr(xlabelFrame, text=gettextRcmdr("X axis label")), xlabelField, sticky = "w") tkgrid(labelRcmdr(ylabelFrame, text=gettextRcmdr("Y axis label")), ylabelField, sticky = "w") tkgrid(xlabelFrame, labelRcmdr(axisFrame, text=" "), ylabelFrame, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("X axis range(Min, Max) Ex: 0, 365")), xlimEntry, sticky="w") # tkgrid.configure(xlimEntry, sticky="w") # tkgrid(tklabel(axisFrame, text=gettextRcmdr("Y axis range(Min, Max) Ex: 0.8, 1.0")), ylimEntry, sticky="w") # tkgrid.configure(ylimEntry, sticky="w") tkgrid(axisFrame, sticky="w") StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedCoxTD <- function(){ # add the class coxph to the modelClasses xx <- getRcmdr("modelClasses") bolCoxphExists = FALSE for(ii in 1:length(xx)){if (xx[ii] == "coxph") bolCoxphExists = TRUE} if (bolCoxphExists == FALSE) putRcmdr("modelClasses", c(getRcmdr("modelClasses"), "coxph")) defaults <- list(SurvivalTimeVariable = "", StatusVariable = "", rhs = "", waldVariable = 0, prophazVariable = 0, basecurveVariable = 0, actmodelVariable = 0, stepwise1Variable = 0, stepwise2Variable = 0, stepwise3Variable = 0, subset = "", timepositive = NULL, timenegative = NULL) dialog.values <- getDialog("StatMedCoxTD", defaults) currentFields$SurvivalTimeVariable <- dialog.values$SurvivalTimeVariable currentFields$StatusVariable <- dialog.values$StatusVariable currentFields$rhs <- dialog.values$rhs currentFields$subset <- dialog.values$subset initializeDialog(title=gettextRcmdr("Cox proportional hazard regression with time-dependent covariate")) .activeModel <- ActiveModel() currentModel <- if (!is.null(.activeModel)) class(get(.activeModel, envir=.GlobalEnv))[1] == "coxph" # eval(parse(text=paste("class(", .activeModel, ")[1] == 'coxph'", sep="")), # envir=.GlobalEnv) else FALSE currentModel <- TRUE # if(currentModel){ # currentFields <- formulaFields(eval(parse(text=.activeModel), # envir=.GlobalEnv)) # if (currentFields$data != ActiveDataSet()) currentModel <- FALSE # } UpdateModelNumber() modelName <- tclVar(paste("CoxModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="30", textvariable=modelName) variablesFrame <- tkframe(top) # timedependentcovariateBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-dependent (TD) covariate (pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$timedependentcovariate, "all")) # timepositiveBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time when TD covariate changes from 0 to 1(pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$timepositive, "all")) timepositiveBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Time when TD covariate changes from 0 to 1(pick at least one)"), listHeight=7, initialSelection=varPosn(dialog.values$timepositive, "all")) timenegativeBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time when TD covariate changes from 1 to 0(pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$timenegative, "all")) textFrame <- tkframe(top) text2Frame <- tkframe(top) optionsFrame <- tkframe(top) checkBoxes(frame="checkboxFrame", boxes=c("wald", "prophaz", "basecurve", "actmodel", "stepwise1", "stepwise2", "stepwise3"), initialValues=c(dialog.values$waldVariable, dialog.values$prophazVariable, dialog.values$basecurveVariable, dialog.values$actmodelVariable, dialog.values$stepwise1Variabl, dialog.values$stepwise2Variabl, dialog.values$stepwise3Variabl),labels=gettextRcmdr(c("Wald test for overall p-value for factors with >2 levels", "Test proportional hazards assumption","Show baseline survival curve", "Keep results as active model for further analyses", "Stepwise selection based on AIC", "Stepwise selection based on BIC", "Stepwise selection based on p-value"))) # waldVariable <- tclVar("0") # waldCheckBox <- tkcheckbutton(optionsFrame, variable=waldVariable) # prophazVariable <- tclVar("0") # prophazCheckBox <- tkcheckbutton(optionsFrame, variable=prophazVariable) # basecurveVariable <- tclVar("0") # basecurveCheckBox <- tkcheckbutton(optionsFrame, variable=basecurveVariable) # actmodelVariable <- tclVar("0") # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) # stepwise1Variable <- tclVar("0") # stepwise1CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise1Variable) # stepwise2Variable <- tclVar("0") # stepwise2CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise2Variable) # stepwise3Variable <- tclVar("0") # stepwise3CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise3Variable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Cox proportional hazard regression with time-dependent covariate"), "#####", sep="")) # XXX <- getSelection(timeBox) modelValue <- trim.blanks(tclvalue(modelName)) # timedependentcovariate <- getSelection(timedependentcovariateBox) timepositive <- getSelection(timepositiveBox) timenegative <- getSelection(timenegativeBox) wald <- tclvalue(waldVariable) prophaz <- tclvalue(prophazVariable) basecurve <- tclvalue(basecurveVariable) actmodel <- tclvalue(actmodelVariable) stepwise1 <- tclvalue(stepwise1Variable) stepwise2 <- tclvalue(stepwise2Variable) stepwise3 <- tclvalue(stepwise3Variable) subset <- tclvalue(subsetVariable) # if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") # || trim.blanks(subset) == ""){ # subset <- "" # putRcmdr("modelWithSubset", FALSE) # } # else{ # subset <- paste(", subset=", subset, sep="") # putRcmdr("modelWithSubset", TRUE) # } putDialog("StatMedCoxTD", list(SurvivalTimeVariable = tclvalue(SurvivalTimeVariable), StatusVariable = tclvalue(StatusVariable), rhs = tclvalue(rhsVariable), waldVariable = wald, prophazVariable = prophaz, basecurveVariable = basecurve, actmodelVariable = actmodel, stepwise1Variable = stepwise1, stepwise2Variable = stepwise2, stepwise3Variable = stepwise3, subset=tclvalue(subsetVariable), timepositive = timepositive, timenegative = timenegative)) # if (length(timedependentcovariate) == 0 || length(timepositive) == 0){ if (length(timepositive) == 0){ errorCondition(recall=StatMedCoxTD, message=gettextRcmdr("Pick all required variables")) return() } # if (length(timenegative) == 0){ # timenegative <- tclvalue(SurvivalTimeVariable) # } if (!is.valid.name(modelValue)){ errorCondition(recall=StatMedCoxTD, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } # check.empty <- gsub(" ", "", tclvalue(lhsVariable)) # if ("" == check.empty) { # errorCondition(recall=StatMedCoxRegression, # message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) # return() # } check.empty <- gsub(" ", "", tclvalue(SurvivalTimeVariable)) if ("" == check.empty) { errorCondition(recall=StatMedCoxTD, message=gettextRcmdr("Survival time variable of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(StatusVariable)) if ("" == check.empty) { errorCondition(recall=StatMedCoxTD, message=gettextRcmdr("Status variable of model empty."), model=TRUE) return() } ncov <- length(timepositive) if(ncov==1){ covariates <- paste(timepositive, "_td", sep="") } else { covariates <- paste(timepositive, collapse="_td + ") covariates <- paste(covariates, "_td", sep="") } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" != check.empty) { covariates <- paste(covariates, " + ", tclvalue(rhsVariable), sep="") } if (is.element(modelValue, listCoxModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) StatMedCoxTD() return() } } closeDialog() Library("survival") Library("aod") dataSet <- activeDataSet() if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ doItAndPrint(paste("TempDF <- ", dataSet, sep="")) } else{ doItAndPrint(paste("TempDF <- subset(", dataSet, ", ",subset, ")", sep="")) } # doItAndPrint(paste("attach(", dataSet, ")")) # command <- paste("TempTD <- stsplit(TempDF, TempDF$", tclvalue(SurvivalTimeVariable), ", TempDF$", tclvalue(StatusVariable), ", TempDF$", timepositive, ", TempDF$", timedependentcovariate, ", TempDF$", timenegative, ")", sep="") for (i in 1:ncov){ command <- paste("TempDF$", timepositive[i], " <- ifelse(TempDF$", timepositive[i], " <= 0, 0.001, TempDF$", timepositive[i], ")", sep="") doItAndPrint(command) } ###New lines for tmerge() doItAndPrint("TempDF$patientsnumber_td <- 1:nrow(TempDF)") command <- paste("TempDF <- TempDF[complete.cases(TempDF$", tclvalue(SurvivalTimeVariable), ", TempDF$", tclvalue(StatusVariable), sep="") for(i in 1:ncov){ command <- paste(command, ", TempDF$", timepositive[i], sep="") } if(length(timenegative) >0){ command <- paste(command, ", TempDF$", timenegative, sep="") } command <- paste(command, "),]", sep="") doItAndPrint(command) command <- paste("TempDF$", tclvalue(SurvivalTimeVariable), "<- ifelse(TempDF$", tclvalue(SurvivalTimeVariable), "<=0, 0.001, TempDF$", tclvalue(SurvivalTimeVariable), ")", sep="") doItAndPrint(command) command <- paste("TempTD <- tmerge(TempDF, TempDF, tstop=", tclvalue(SurvivalTimeVariable), ", id=patientsnumber_td, endpoint_td=event(", tclvalue(SurvivalTimeVariable), ", ", tclvalue(StatusVariable), '), options=list(tstartname="start_td", tstopname="stop_td", idname="patientsnumber_td"))', sep="") doItAndPrint(command) command <- "TempTD <- tmerge(TempTD, TempTD, id=patientsnumber_td" for(i in 1:ncov){ command <- paste(command, ", ", timepositive[i], "_td=tdc(", timepositive[i], ")", sep="") } command <- paste(command, ")", sep="") doItAndPrint(command) if(ncov==1 & length(timenegative)>0){ command <- paste("TempTD$", timenegative, " <- ifelse(TempTD$", timenegative, " < TempTD$", timepositive, ", TempTD$", tclvalue(SurvivalTimeVariable), ", TempTD$", timenegative, ")", sep="") doItAndPrint(command) command <- paste("TempTD <- tmerge(TempTD, TempTD, id=patientsnumber_td, ", timepositive[1], "_td=tdc(", timenegative, "))", sep="") doItAndPrint(command) command <- paste("TempTD <- tmerge(TempTD, TempTD, id=patientsnumber_td, ", timepositive[1], "_td=cumtdc(start_td))", sep="") doItAndPrint(command) command <- paste("TempTD$", timepositive[1], "_td <- TempTD$", timepositive[1], "_td + 1 - ceiling(TempTD$", timepositive[1], "_td/2)*2", sep="") doItAndPrint(command) } ###New lines for tmerge() End ###For stsplit.new() # if(ncov==1){ # command <- paste('TempTD <- stsplit.new(TempDF, timetoevent="', tclvalue(SurvivalTimeVariable), '", event="', tclvalue(StatusVariable), '", time="', timepositive, '", timeoff=0)', sep="") # result <- doItAndPrint(command) # if(length(timenegative) >0){ # command <- paste('TempTD <- stsplit.new(TempTD, timetoevent="', tclvalue(SurvivalTimeVariable), '", event="', tclvalue(StatusVariable), '", time="', timenegative, '", timeoff=1, td="', timepositive, '")', sep="") # result <- doItAndPrint(command) # } # } else { # command <- paste('TempTD <- stsplit.new(TempDF, timetoevent="', tclvalue(SurvivalTimeVariable), '", event="', tclvalue(StatusVariable), '", time="', timepositive[1], '", timeoff=0)', sep="") # result <- doItAndPrint(command) # for (i in 2:ncov){ # command <- paste('TempTD <- stsplit.new(TempTD, timetoevent="', tclvalue(SurvivalTimeVariable), '", event="', tclvalue(StatusVariable), '", time="', timepositive[i], '", timeoff=0)', sep="") # result <- doItAndPrint(command) # } # } # library(survival) # formula <- paste("Surv(", XXX, ", ", tclvalue(lhsVariable), ") ~ ", tclvalue(rhsVariable), sep="") # formula <- paste("Surv(", tclvalue(SurvivalTimeVariable), ", ", tclvalue(StatusVariable), ")~ ", tclvalue(rhsVariable), sep="") formula <- paste("Surv(start_td, stop_td, endpoint_td==1) ~ ", covariates, sep="") # command <- paste("coxph(", formula, # ", data=TempTD", subset, ', method="breslow")', sep="") command <- paste("coxph(", formula, ', data=TempTD, method="breslow")', sep="") # logger(paste(modelValue, " <- ", command, sep="")) # assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(modelValue, " <- ", command, sep="")) doItAndPrint("res <- NULL") doItAndPrint(paste("(res <- summary(", modelValue, "))", sep="")) # doItAndPrint(paste("res <- ", command, sep="")) # doItAndPrint("res <- summary(res)") doItAndPrint("cox.table <- NULL") if(eval(parse(text="length(res$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res$coefficients)") doItAndPrint('colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } else { doItAndPrint("cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } # doItAndPrint("cox.table <- signif(cox.table, digits=3)") doItAndPrint("cox.table") if (wald==1) doItAndPrint(paste("waldtest(", modelValue, ")", sep="")) if (prophaz == 1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} nvar <- (eval(parse(text="length(cox.table[,1])"))) mfrow <- paste("c(4,", ceiling(nvar/4), ")", sep="") switch(as.character(nvar), "1"=mfrow <- "c(1,1)", "2"=mfrow <- "c(2,1)", "3"=mfrow <- "c(2,2)", "4"=mfrow <- "c(2,2)", "5"=mfrow <- "c(3,2)", "6"=mfrow <- "c(3,2)", "7"=mfrow <- "c(3,3)", "8"=mfrow <- "c(3,3)", "9"=mfrow <- "c(3,3)", "10"=mfrow <- "c(4,3)", "11"=mfrow <- "c(4,3)", "12"=mfrow <- "c(4,3)" ) doItAndPrint(paste("oldpar <- par(oma=c(0,0,3,0), mfrow=", mfrow, ")", sep="")) doItAndPrint(paste("plot(cox.zph(", modelValue, "), df=2)", sep="")) doItAndPrint("par(oldpar)") doItAndPrint(paste("print(cox.zph(", modelValue, "))", sep="")) } if (basecurve ==1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint(paste("plot(survfit(", modelValue, "))", sep="")) } if (stepwise1 == 1 | stepwise2 == 1 | stepwise3 == 1){ x <- strsplit(tclvalue(rhsVariable), split="\\+") if (length(x[[1]]>0)){ command <- paste("TempDF <- with(TempTD, TempTD[complete.cases(", paste(x[[1]], collapse=","), "),])", sep="") } doItAndPrint(command) command <- paste("coxph(", formula, ', data=TempDF, method="breslow")', sep="") doItAndPrint(paste(modelValue, " <- ", command, sep="")) } if (stepwise1 == 1){ doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="AIC")', sep="")) doItAndPrint("summary(res)") doItAndPrint("res2 <- summary(res)") if(eval(parse(text="length(res2$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res2$conf.int[,c(1,3,4)]), p.value=res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res2$coefficients)") doItAndPrint('colnames(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } else if(eval(parse(text="length(res2$coefficients[,1])"))>1){ doItAndPrint("cox.table <- signif(cbind(res2$conf.int[,c(1,3,4)], res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('names(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } if (wald==1) doItAndPrint("waldtest(res)") } if (stepwise2 == 1){ doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="BIC")', sep="")) doItAndPrint("summary(res)") doItAndPrint("res2 <- summary(res)") if(eval(parse(text="length(res2$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res2$conf.int[,c(1,3,4)]), p.value=res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res2$coefficients)") doItAndPrint('colnames(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } else if(eval(parse(text="length(res2$coefficients[,1])"))>1){ doItAndPrint("cox.table <- signif(cbind(res2$conf.int[,c(1,3,4)], res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('names(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } # doItAndPrint("cox.table") if (wald==1) doItAndPrint("waldtest(res)") } if (stepwise3 == 1){ subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" } else{ subset <- paste(", subset='", trim.blanks(subset), "'", sep="") } doItAndPrint(paste('step.p.coxtd(', modelValue, ', "TempDF", wald=', wald, subset, ")", sep="")) } # doItAndPrint("remove(res)") if (actmodel==1) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="coxph", model=TRUE, apply="StatMedCoxTD", reset="StatMedCoxTD") tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") modelFormulaCox() StatMedSubsetBox(model=TRUE) tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(labelRcmdr(textFrame, text=paste(" ", gettextRcmdr("Stratifing variable: + strata(#####)"), sep="")), sticky="e") tkgrid(textFrame, sticky="w") # tkgrid(getFrame(timedependentcovariateBox), labelRcmdr(variablesFrame, text=" "), getFrame(timepositiveBox), getFrame(timenegativeBox), sticky="nw") tkgrid(getFrame(timepositiveBox), getFrame(timenegativeBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(text2Frame, text=gettextRcmdr("If more than 1 are picked, 1 to 0 variable is not be used."), fg="blue"), sticky="w") tkgrid(text2Frame, sticky="w") tkgrid(checkboxFrame, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Wald test for overall p-value for factors with >2 levels")), waldCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Test proportional hazards assumption")), prophazCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Show baseline survival curve")), basecurveCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Keep results as active model for further analyses")), actmodelCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on AIC")), stepwise1CheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on BIC")), stepwise2CheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on p-value")), stepwise3CheckBox, sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } StatMedCrrTD <- function(){ defaults <- list(event = "", timetoevent = "", group = "", fcode = 1, wald = 0, stepwise1 = 0, stepwise2 = 0, stepwise3 = 0, subset = "", timepositive = NULL, timenegative = NULL) dialog.values <- getDialog("StatMedCrrTD", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Fine-Gray proportional hazard regression with time-dependent covariate")) variablesFrame <- tkframe(top) fcodeFrame <- tkframe(top) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1,2,3...) (pick one)"), listHeight=10, initialSelection=varPosn(dialog.values$event, "all")) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=10, initialSelection=varPosn(dialog.values$timetoevent, "all")) groupBox <- variableListBox(variablesFrame, Variables(), selectmode="multiple", title=gettextRcmdr("Explanatory variables (pick 0, 1, or more)"), listHeight=10, initialSelection=varPosn(dialog.values$group, "all")) variables2Frame <- tkframe(top) # timedependentcovariateBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Time-dependent (TD) covariate (pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$timedependentcovariate, "all")) # timepositiveBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Time when TD covariate changes from 0 to 1(pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$timepositive, "all")) timepositiveBox <- variableListBox(variables2Frame, Variables(), selectmode="multiple", title=gettextRcmdr("Time when TD covariate changes from 0 to 1(pick at least one)"), listHeight=7, initialSelection=varPosn(dialog.values$timepositive, "all")) timenegativeBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Time when TD covariate changes from 1 to 0(pick one)"), listHeight=7, initialSelection=varPosn(dialog.values$timenegative, "all")) fcodeFrame <- tkframe(top) fcodeVariable <- tclVar(dialog.values$fcode) fcodeField <- ttkentry(fcodeFrame, width="20", textvariable=fcodeVariable) # fcode <- tclVar("1") # fcodeEntry <- ttkentry(fcodeFrame, width="10", textvariable=fcode) textFrame <- tkframe(top) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("wald", "stepwise1", "stepwise2", "stepwise3"), initialValues=c(dialog.values$wald, dialog.values$stepwise1, dialog.values$stepwise2, dialog.values$stepwise3),labels=gettextRcmdr(c("Wald test for overall p-value for factors with >2 levels", "Stepwise selection based on AIC", "Stepwise selection based on BIC", "Stepwise selection based on p-value"))) # waldVariable <- tclVar("0") # waldCheckBox <- tkcheckbutton(optionsFrame, variable=waldVariable) # stepwise1Variable <- tclVar("0") # stepwise1CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise1Variable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Fine-Gray proportional hazard regression for competing events"), "#####", sep="")) event <- getSelection(eventBox) timetoevent <- getSelection(timetoeventBox) group <- getSelection(groupBox) # timedependentcovariate <- getSelection(timedependentcovariateBox) timepositive <- getSelection(timepositiveBox) timenegative <- getSelection(timenegativeBox) fcode <- tclvalue(fcodeVariable) wald <- tclvalue(waldVariable) stepwise1 <- tclvalue(stepwise1Variable) stepwise2 <- tclvalue(stepwise2Variable) stepwise3 <- tclvalue(stepwise3Variable) subset <- tclvalue(subsetVariable) # if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") # || trim.blanks(subset) == ""){ # subset <- "" # } # else{ # subset <- paste(", subset=", subset, sep="") # } putDialog("StatMedCrrTD", list(event = event, timetoevent = timetoevent, group = group, fcode = fcode, wald = wald, stepwise1 = stepwise1, stepwise2 = stepwise2, stepwise3 = stepwise3, subset = tclvalue(subsetVariable), timepositive = timepositive, timenegative = timenegative)) # if (length(timedependentcovariate) == 0 || length(timepositive) == 0){ if (length(timepositive) == 0){ errorCondition(recall=StatMedCrrTD, message=gettextRcmdr("Pick all required variables")) return() } # if (length(timenegative) == 0){ # timenegative <- timetoevent # } if (length(event) != 1) { errorCondition(recall=StatMedCrrTD, ) message=gettextRcmdr("Pick one status indicator (censor=0, event=1,2,3...)") return() } if (length(timetoevent) != 1) { errorCondition(recall=StatMedCrrTD, message=gettextRcmdr("Pick one time-to-event variable")) return() } # if (length(group) == 0) { # errorCondition(recall=StatMedCrrTD, # message=gettextRcmdr("Pick at least one explanatory variable")) # return() # } if (length(fcode) == 0) { errorCondition(recall=StatMedCrrTD, message=gettextRcmdr("Specify one event of interest")) return() } # if (is.element(modelValue, listCoxModels())) { # if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ # UpdateModelNumber(-1) # StatMedCoxTD() # return() # } # } closeDialog() Library("survival") Library("cmprsk") Library("aod") dataSet <- activeDataSet() if (trim.blanks(subset) == gettextRcmdr( "<all valid cases>") || trim.blanks(subset) == ""){ doItAndPrint(paste("TempDF <- ", dataSet, sep="")) } else{ doItAndPrint(paste("TempDF <- subset(", dataSet, ", ",subset, ")", sep="")) } # command <- paste("TempDF <- TempDF[complete.cases(TempDF$", timetoevent, ", TempDF$", event, ", TempDF$", timepositive, ", TempDF$", timedependentcovariate, ", TempDF$", timenegative, "),]", sep="") # if (length(timenegative) == 0){ # command <- paste("TempDF <- TempDF[complete.cases(TempDF$", timetoevent, ", TempDF$", event, ", TempDF$", timepositive, "),]", sep="") # } else { # command <- paste("TempDF <- TempDF[complete.cases(TempDF$", timetoevent, ", TempDF$", event, ", TempDF$", timepositive, ", TempDF$", timenegative, "),]", sep="") # } # doItAndPrint(command) # doItAndPrint(paste("attach(", dataSet, ")")) ncov <- length(timepositive) for (i in 1:ncov){ command <- paste("TempDF$", timepositive[i], " <- ifelse(TempDF$", timepositive[i], " <= 0, 0.001, TempDF$", timepositive[i], ")", sep="") doItAndPrint(command) } # command <- paste("TempTD <- stsplit(TempDF, TempDF$", timetoevent, ", TempDF$", event, ", TempDF$", timepositive, ", TempDF$", timedependentcovariate, ", TempDF$", timenegative, ")", sep="") # result <- doItAndPrint(command) ###New lines for tmerge() doItAndPrint("TempDF$patientsnumber_td <- 1:nrow(TempDF)") command <- paste("TempDF <- TempDF[complete.cases(TempDF$", timetoevent, ", TempDF$", event, sep="") for(i in 1:ncov){ command <- paste(command, ", TempDF$", timepositive[i], sep="") } if(length(timenegative) >0){ command <- paste(command, ", TempDF$", timenegative, sep="") } command <- paste(command, "),]", sep="") doItAndPrint(command) command <- paste("TempDF$", timetoevent, "<- ifelse(TempDF$", timetoevent, "<=0, 0.001, TempDF$", timetoevent, ")", sep="") doItAndPrint(command) command <- paste("TempTD <- tmerge(TempDF, TempDF, tstop=", timetoevent, ", id=patientsnumber_td, endpoint_td=event(", timetoevent, ", ", event, '), options=list(tstartname="start_td", tstopname="stop_td", idname="patientsnumber_td"))', sep="") doItAndPrint(command) command <- "TempTD <- tmerge(TempTD, TempTD, id=patientsnumber_td" for(i in 1:ncov){ command <- paste(command, ", ", timepositive[i], "_td=tdc(", timepositive[i], ")", sep="") } command <- paste(command, ")", sep="") doItAndPrint(command) if(ncov==1 & length(timenegative)>0){ command <- paste("TempTD$", timenegative, " <- ifelse(TempTD$", timenegative, " < TempTD$", timepositive, ", TempTD$", timetoevent, ", TempTD$", timenegative, ")", sep="") doItAndPrint(command) command <- paste("TempTD <- tmerge(TempTD, TempTD, id=patientsnumber_td, ", timepositive[1], "_td=tdc(", timenegative, "))", sep="") doItAndPrint(command) command <- paste("TempTD <- tmerge(TempTD, TempTD, id=patientsnumber_td, ", timepositive[1], "_td=cumtdc(start_td))", sep="") doItAndPrint(command) command <- paste("TempTD$", timepositive[1], "_td <- TempTD$", timepositive[1], "_td + 1 - ceiling(TempTD$", timepositive[1], "_td/2)*2", sep="") doItAndPrint(command) } ###New lines for tmerge() End ####Lines for stsplit.new # if(ncov==1){ # command <- paste('TempTD <- stsplit.new(TempDF, timetoevent="', timetoevent, '", event="', event, '", time="', timepositive, '", timeoff=0)', sep="") # result <- doItAndPrint(command) # if(length(timenegative) >0){ # command <- paste('TempTD <- stsplit.new(TempTD, timetoevent="', timetoevent, '", event="', event, '", time="', timenegative, '", timeoff=1, td="', timepositive, '")', sep="") # result <- doItAndPrint(command) # } # } else { # command <- paste('TempTD <- stsplit.new(TempDF, timetoevent="', timetoevent, '", event="', event, '", time="', timepositive[1], '", timeoff=0)', sep="") # result <- doItAndPrint(command) # for (i in 2:ncov){ # command <- paste('TempTD <- stsplit.new(TempTD, timetoevent="', timetoevent, '", event="', event, '", time="', timepositive[i], '", timeoff=0)', sep="") # result <- doItAndPrint(command) # } # } # doItAndPrint("TempTD$patientsnumber_td <- floor(TempTD$patientsnumber_td)") doItAndPrint(paste('TempTD.CI <- finegray(Surv(start_td, stop_td, as.factor(endpoint_td))~., data=TempTD, na.action= na.pass, etype="', fcode, '", id=patientsnumber_td)',sep="")) if(ncov==1){ cov <- paste(timepositive, "_td", sep="") } else { cov <- paste(timepositive, collapse="_td + ") cov <- paste(cov, "_td", sep="") } nvar <- length(group) if (nvar >= 1){ for (i in 1:nvar) { cov <- paste(cov, " + ", group[i], sep="") } } command <- paste("CrrTD <- coxph(Surv(fgstart, fgstop, fgstatus) ~ ", cov, ', cluster=patientsnumber_td, weight=fgwt, data=TempTD.CI, method="breslow")', sep="") doItAndPrint(command) doItAndPrint("res <- NULL") doItAndPrint("(res <- summary(CrrTD))") # doItAndPrint(paste("res <- ", command, sep="")) # doItAndPrint("res <- summary(res)") doItAndPrint("cox.table <- NULL") if(eval(parse(text="length(res$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res$coefficients)") doItAndPrint('colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } else { doItAndPrint("cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } # doItAndPrint("cox.table <- signif(cox.table, digits=3)") doItAndPrint("cox.table") if (wald==1) doItAndPrint("waldtest(CrrTD)") if (stepwise1 == 1 | stepwise2 == 1 | stepwise3 == 1){ if (nvar >= 1){ cov2 <- group[1] if(nvar >= 2){ for (i in 2:nvar) { cov2 <- paste(cov2, ", ", group[i], sep="") } } } if (nvar >= 1){ command <- paste("TempDF <- with(TempTD.CI, TempTD.CI[complete.cases(", cov2, "),])", sep="") } # else{ # command <- ("TempDF <- with(TempTD.CI, TempTD.CI[complete.cases(covariate_td),])") # } doItAndPrint(command) command <- paste("CrrTD <- coxph(Surv(fgstart, fgstop, fgstatus) ~ ", cov, ', cluster=patientsnumber_td, weight=fgwt, data=TempDF, method="breslow")', sep="") doItAndPrint(command) } if (stepwise1 == 1){ doItAndPrint('res <- stepwise(CrrTD, direction="backward/forward", criterion="AIC")') doItAndPrint("summary(res)") doItAndPrint("res2 <- summary(res)") if(eval(parse(text="length(res2$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res2$conf.int[,c(1,3,4)]), p.value=res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res2$coefficients)") doItAndPrint('colnames(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } else if(eval(parse(text="length(res2$coefficients[,1])"))>1){ doItAndPrint("cox.table <- signif(cbind(res2$conf.int[,c(1,3,4)], res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('names(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } if (wald==1) doItAndPrint("waldtest(res)") } if (stepwise2 == 1){ doItAndPrint('res <- stepwise(CrrTD, direction="backward/forward", criterion="BIC")') doItAndPrint("summary(res)") doItAndPrint("res2 <- summary(res)") if(eval(parse(text="length(res2$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res2$conf.int[,c(1,3,4)]), p.value=res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res2$coefficients)") doItAndPrint('colnames(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } else if(eval(parse(text="length(res2$coefficients[,1])"))>1){ doItAndPrint("cox.table <- signif(cbind(res2$conf.int[,c(1,3,4)], res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('names(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } # doItAndPrint("cox.table") if (wald==1) doItAndPrint("waldtest(res)") } if (stepwise3 == 1){ subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ subset <- "" } else{ subset <- paste(", subset='", trim.blanks(subset), "'", sep="") } doItAndPrint(paste('step.p.coxcrrtd(CrrTD, "TempDF", wald=', wald, subset, ")", sep="")) } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="crr", apply="StatMedCrrTD", reset="StatMedCrrTD") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), labelRcmdr(variablesFrame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("Dummy variables required for factors of more than 2 groups"), fg="blue"), sticky="e") tkgrid(labelRcmdr(fcodeFrame, text=gettextRcmdr("Input code of event of interest"), fg="blue"), fcodeField, sticky = "w") tkgrid(fcodeFrame, sticky="w") # tkgrid(getFrame(timedependentcovariateBox), labelRcmdr(variables2Frame, text=" "), getFrame(timepositiveBox), getFrame(timenegativeBox), sticky="nw") tkgrid(getFrame(timepositiveBox), getFrame(timenegativeBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(labelRcmdr(textFrame, text=gettextRcmdr("If more than 1 are picked, 1 to 0 variable is not be used."), fg="blue"), sticky="w") tkgrid(textFrame, sticky="w") # tkgrid(tklabel(fcodeFrame, text=gettextRcmdr("Input code of event of interest"), fg="blue"), fcodeEntry, sticky="w") # tkgrid.configure(fcodeEntry, sticky="w") # tkgrid(fcodeFrame, sticky="w") tkgrid(getFrame(groupBox), sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Wald test for overall p-value for factors with >2 levels")), waldCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on p-value")), stepwise1CheckBox, sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedCurrentSurvival <- function(){ Library("currentSurvival") Library("survival") defaults <- list(StartPoint=NULL, follow.up=NULL, event=NULL, group=NULL, conf.int=0, com.est=0, interval=365, col=0, cci=0) dialog.values <- getDialog("StatMedCurrentSurvival", defaults) initializeDialog(title=gettextRcmdr("Current survival and current cmulative incidence")) env <- environment() variablesFrame <- tkframe(top) variables2Frame <- tkframe(top) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$follow.up, "all")) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1) (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$event, "all")) variables2Frame <- tkframe(top) startpointBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Time for first event-free status"), listHeight=8, initialSelection=varPosn(dialog.values$StartPoint, "all")) groupBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), listHeight=8, initialSelection=varPosn(dialog.values$group, "all")) optionsFrame <- tkframe(top) checkBoxes(window=optionsFrame, frame="ci", boxes=c("ci"), initialValues=c(dialog.values$conf.int),labels=gettextRcmdr(c("Show 95% confidence intervals")), title=gettextRcmdr(" ")) checkBoxes(window=optionsFrame, frame="com.est", boxes=c("com.est"), initialValues=c(dialog.values$com.est),labels=gettextRcmdr(c("Show common event-free survival")), title=gettextRcmdr(" ")) checkBoxes(window=optionsFrame, frame="col", boxes=c("col"), initialValues=c(dialog.values$col),labels=gettextRcmdr(c("Draw in color")), title=gettextRcmdr(" ")) checkBoxes(window=optionsFrame, frame="cci", boxes=c("cci"), initialValues=c(dialog.values$cci),labels=gettextRcmdr(c("Show current cumulative incidence")), title=gettextRcmdr(" ")) axisFrame <- tkframe(top) intervalFrame <- tkframe(axisFrame) intervalVariable <- tclVar(dialog.values$interval) intervalField <- ttkentry(intervalFrame, width="20", textvariable=intervalVariable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Current survival and current cmulative incidence"), "#####", sep="")) follow.up <- getSelection(timetoeventBox) event <- getSelection(eventBox) StartPoint <- getSelection(startpointBox) group <- getSelection(groupBox) conf.int <- tclvalue(ciVariable) com.est <- tclvalue(com.estVariable) col <- tclvalue(colVariable) cci <- tclvalue(cciVariable) interval <- tclvalue(intervalVariable) dataSet <- activeDataSet() putDialog("StatMedCurrentSurvival", list(StartPoint=StartPoint, follow.up=follow.up, event=event, group=group, conf.int=conf.int, com.est=com.est, interval=interval, col=col, cci=cci)) com.est <- ifelse(com.est==1, "TRUE", "FALSE") group <- ifelse(length(group)==0, "NULL", paste("'", group, "'", sep="")) pvals <- ifelse(length(group)==0, "FALSE", "TRUE") if (length(event) != 1) { errorCondition(recall=StatMedCurrentSurvival, message=gettextRcmdr("Pick one status indicator (censor=0, event=1)")) return() } if (length(follow.up) != 1) { errorCondition(recall=StatMedCurrentSurvival, message=gettextRcmdr("Pick one time-to-event variable")) return() } if (length(StartPoint) != 1) { errorCondition(recall=StatMedCurrentSurvival, message=gettextRcmdr("Pick one time for first event-free status variable")) return() } Selecting <- 1 i <- 1 EventOnOff <- NULL while(Selecting==1){ if(i!=2*floor(i/2)){ Next <- paste(gettextRcmdr("Time for No."), (i+1)/2, gettextRcmdr("event on"), sep=" ") } else { Next <- paste(gettextRcmdr("Time for No."), 1 + i/2, gettextRcmdr("event off"), sep=" ") } initializeDialog(subdialog, title=Next) eventonoffBox <- variableListBox(subdialog, Variables(), title=Next, listHeight=10) onOKsub <- function() { selection <- getSelection(eventonoffBox) closeDialog(subdialog) assign("selection", selection, envir=env) #send selection out of subdialog } subOKCancelHelp() tkgrid(getFrame(eventonoffBox), labelRcmdr(subdialog, text=gettextRcmdr("If finished, just click OK."), fg="blue"), sticky="nw") tkgrid(subButtonsFrame, sticky="w") dialogSuffix(subdialog, rows=6, columns=2, focus=subdialog, onOK=onOKsub, force.wait=TRUE) if(length(selection)==0) { break } else { EventOnOff[i] <- selection } i <- i+1 } closeDialog() if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} command <- paste("CurrentSurvival(Dataset=", dataSet, ", StartPoint='", StartPoint, "', EventOnOff=c('", sep="") command <- paste(command, paste(EventOnOff, collapse="', '"), "'), ", sep="") command <- paste(command, "follow.up='", follow.up, "', event='", event, "', strat=", group, ", conf.int=", conf.int, ", com.est=", com.est, ", pvals=", pvals, ", intervals=", interval, ", col=", col, ", cci=", cci, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="survfit", model=TRUE, apply="StatMedKaplanMeier", reset="StatMedKaplanMeier") tkgrid(labelRcmdr(top, text=gettextRcmdr("Select other event on/off variable after clicking OK."), fg="blue"), sticky="nw") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(startpointBox), labelRcmdr(variables2Frame, text=" "), getFrame(groupBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(ci, labelRcmdr(optionsFrame, text=" "), com.est, labelRcmdr(optionsFrame, text=" "), col, labelRcmdr(optionsFrame, text=" "), cci, sticky="w") tkgrid(optionsFrame, sticky="nw") tkgrid(labelRcmdr(intervalFrame, text=gettextRcmdr("X axis tick interval")), intervalField, sticky = "w") tkgrid(intervalFrame, sticky="w") tkgrid(axisFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedROC <- function(){ defaults <- list(response=NULL, predictor=NULL, threshold=1, direction="auto", best="youden", cost="1", prevalence="0.5", subset = "") dialog.values <- getDialog("StatMedROC", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE Library("pROC") Library("methods") initializeDialog(title=gettextRcmdr("ROC curve analysis for quantitative test")) variablesFrame <- tkframe(top) responseBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Response (encoded as 0 or 1) (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$response, "all")) predictorBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Predictor (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$predictor, "all")) optionsFrame <- tkframe(top) radioButtons(optionsFrame, name="direction", buttons=c("auto", "higher", "lower"), initialValue=dialog.values$direction, values=c("auto", "<", ">"), labels=gettextRcmdr(c("Automatic", ">=threshold as positive", "<=threshold as positive")),title=gettextRcmdr("Direction for comparison")) radioButtons(optionsFrame, name="best", buttons=c("youden", "closest.topleft"), initialValue=dialog.values$best, values=c("youden", "closest.topleft"), labels=gettextRcmdr(c("Maximum sum of sensitivity + specificity", "Closest to the top-left corner")),title=gettextRcmdr("Optimal threshold")) checkBoxFrame <- tkframe(top) checkBoxes(frame="checkBoxFrame", boxes="threshold", initialValues=dialog.values$threshold,labels=gettextRcmdr("Show optimal threshold in graph")) # checkBoxes(frame="threshold", boxes=c("thres"),initialValues=c(1),labels=gettextRcmdr(c("Show optimal threshold in graph"))) costFrame <- tkframe(top) costVariable <- tclVar(dialog.values$cost) costField <- ttkentry(costFrame, width="6", textvariable=costVariable) prevalenceFrame <- tkframe(top) prevalenceVariable <- tclVar(dialog.values$prevalence) prevalenceField <- ttkentry(prevalenceFrame, width="6", textvariable=prevalenceVariable) # costFrame <- tkframe(top) # costVariable <- tclVar("1") # costField <- ttkentry(costFrame, width="8", textvariable=costVariable) # prevalenceFrame <- tkframe(top) # prevalenceVariable <- tclVar("0.5") # prevalenceField <- ttkentry(prevalenceFrame, width="8", textvariable=prevalenceVariable) onOK <- function(){ logger(paste("#####", gettextRcmdr("ROC curve analysis for quantitative test"), "#####", sep="")) response <- getSelection(responseBox) predictor <- getSelection(predictorBox) direction <- tclvalue(directionVariable) best <- tclvalue(bestVariable) cost <- tclvalue(costVariable) prevalence <- tclvalue(prevalenceVariable) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") } putDialog("StatMedROC", list(response=response, predictor=predictor, threshold=tclvalue(thresholdVariable), direction=direction, best=best, cost=cost, prevalence=prevalence, subset = tclvalue(subsetVariable))) if (length(response) == 0 || length(predictor) == 0){ errorCondition(recall=StatMedROC, message=gettextRcmdr("You must select two variables.")) return() } closeDialog() if (tclvalue(thresholdVariable) == "1"){ pt <- paste(', print.thres="best", print.thres.best.method="', best, '", print.thres.best.weights=c(', cost, ", ", prevalence, ")", sep="") cpt <- paste(', "best", best.method="', best, '", best.weights=c(', cost, ", ", prevalence, ")", sep="") } else{ pt <- ", print.thres=NULL" cpt <- ", 1" } doItAndPrint("ROC <- NULL") command <- paste("ROC <- roc(", response, "~", predictor, ", data=", subset1, ActiveDataSet(), subset2, ', ci=TRUE, direction="', direction, '")', sep="") doItAndPrint(command) # doItAndPrint("if(ROC$thresholds[1]==-Inf) {ROC$thresholds[1:(length(levels(factor(ROC$predictor))))] <- as.numeric(levels(factor(ROC$predictor)))}") # doItAndPrint("if(ROC$thresholds[1]==Inf) {ROC$thresholds[1:(length(levels(factor(ROC$predictor))))] <- rev(as.numeric(levels(factor(ROC$predictor))))}") doItAndPrint("if(ROC$thresholds[1]==-Inf){thre <- c(unique(sort(ROC$predictor)), Inf)}") doItAndPrint("if(ROC$thresholds[1]==Inf){thre <- c(unique(sort(ROC$predictor, decreasing=TRUE)), -Inf)}") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} # doItAndPrint('plot(ROC$thresholds, ROC$sensitivities, ylim=c(0,1), type="l", ylab="Sensitivity/Specificity", xlab="Threshold")') doItAndPrint('plot(thre, ROC$sensitivities, ylim=c(0,1), type="l", ylab="Sensitivity/Specificity", xlab="Threshold")') doItAndPrint("par(new=T)") # doItAndPrint('plot(ROC$thresholds,ROC$specificities, ylim=c(0,1), type="l", lty=2, ylab="", xlab="")') doItAndPrint('plot(thre, ROC$specificities, ylim=c(0,1), type="l", lty=2, ylab="", xlab="", col.axis=0)') doItAndPrint('legend("bottom", horiz=TRUE, c("Sensitivity", "Specificity"), lty=1:2, box.lty=0)') if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} ###conflicts with colorspace package:coords and therefore use pROC::coords in ROC function doItAndPrint(paste("co <- pROC::coords(ROC", cpt, ", transpose = FALSE)", sep="")) ###", transpose = FALSE" added from pROC 1.15 doItAndPrint("if(ROC$thresholds[1]==-Inf){co[,1] <- min(ROC$predictor[ROC$predictor>co[,1]])}") ###Change to exact values doItAndPrint("if(ROC$thresholds[1]==Inf)co[,1] <- max(ROC$predictor[ROC$predictor<co[,1]])") ###Change to exact values if (tclvalue(thresholdVariable) == "1") { doItAndPrint("plot(ROC, print.thres=co[,1], grid=TRUE)") } else { doItAndPrint("plot(ROC, print.thres=NULL, grid=TRUE)") } # if(eval(parse(text="class(co)"))=="matrix"){ #checking for matrix removed from pROC 1.15 # doItAndPrint("if(ROC$thresholds[1]==-Inf){co[1,] <- min(ROC$predictor[ROC$predictor>co[1,]])}") ###Change to exact values # doItAndPrint("if(ROC$thresholds[1]==Inf)co[1,] <- max(ROC$predictor[ROC$predictor<co[1,]])") ###Change to exact values # if (tclvalue(thresholdVariable) == "1") { # doItAndPrint("plot(ROC, print.thres=co[1,], grid=TRUE)") # } else { # doItAndPrint("plot(ROC, print.thres=NULL, grid=TRUE)") # } # } else { # doItAndPrint("if(ROC$thresholds[1]==-Inf){co[1] <- min(ROC$predictor[ROC$predictor>co[1]])}") ###Change to exact values # doItAndPrint("if(ROC$thresholds[1]==Inf)co[1] <- max(ROC$predictor[ROC$predictor<co[1]])") ###Change to exact values # if (tclvalue(thresholdVariable) == "1") { # doItAndPrint("plot(ROC, print.thres=co[1], grid=TRUE)") # } else { # doItAndPrint("plot(ROC, print.thres=NULL, grid=TRUE)") # } # } # doItAndPrint('coords(ROC, "all")') doItAndPrint("if(ROC$thresholds[1]==-Inf){pROC::coords(ROC, x=c(-Inf, unique(sort(ROC$predictor)), Inf), transpose = FALSE)}") ###", transpose = FALSE" added from pROC 1.15 doItAndPrint("if(ROC$thresholds[1]==Inf){pROC::coords(ROC, x=c(Inf, unique(sort(ROC$predictor, decreasing=TRUE)), -Inf), transpose = FALSE)}") ###", transpose = FALSE" added from pROC 1.15 if(eval(parse(text="ROC$direction"))==">"){ logger(gettextRcmdr("### <= threshold is considered positive")) }else{ logger(gettextRcmdr("### >= threshold is considered positive")) } doItAndPrint("ROC") doItAndPrint('cat(gettextRcmdr("Area under the curve"), signif(ROC$auc[1], digits=3), gettextRcmdr("95% CI"), signif(ROC$ci[1], digits=3), "-", signif(ROC$ci[3], digits=3), "\n")') # doItAndPrint("remove(ROC)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="roc", apply="StatMedROC", reset="StatMedROC") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), getFrame(predictorBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") # tkgrid(thresholdFrame, sticky="w") tkgrid(checkBoxFrame, sticky="w") # tkgrid(directionFrame, sticky="w") # tkgrid(bestFrame, sticky="w") tkgrid(directionFrame, labelRcmdr(optionsFrame, text=" "), bestFrame, sticky="w") tkgrid(optionsFrame, sticky="nw") tkgrid(labelRcmdr(top, text=gettextRcmdr("Supply weights if false positive and false negative predictions are not equivalent"), fg="blue"), sticky="w") tkgrid(labelRcmdr(costFrame, text=gettextRcmdr("Cost of of false negative classification")), costField, sticky="w") tkgrid(costFrame, sticky="w") tkgrid(labelRcmdr(prevalenceFrame, text=gettextRcmdr("Prevalence")), prevalenceField, sticky="w") tkgrid(prevalenceFrame, sticky="w") StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedROCtest <- function(){ Library("pROC") defaults <- list(response=NULL, predictor1=NULL, predictor2=NULL, subset = "") dialog.values <- getDialog("StatMedROCtest", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Compare two ROC curves")) variablesFrame <- tkframe(top) responseBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Response (encoded as 0 or 1) (pick one)"), listHeight=12, initialSelection=varPosn(dialog.values$response, "all")) variables2Frame <- tkframe(top) predictor1Box <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Predictor1 (pick one)"), listHeight=12, initialSelection=varPosn(dialog.values$predictor1, "all")) predictor2Box <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Predictor2 (pick one)"), listHeight=12, initialSelection=varPosn(dialog.values$predictor2, "all")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Compare two ROC curves"), "#####", sep="")) response <- getSelection(responseBox) predictor1 <- getSelection(predictor1Box) predictor2 <- getSelection(predictor2Box) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset1 <- "" subset2 <- "" subset <- "" } else { subset1 <- "subset(" subset2 <- paste(", ", subset, ")", sep="") subset <- paste(", subset=", subset, sep="") } putDialog("StatMedROCtest", list(response=response, predictor1=predictor1, predictor2=predictor2, subset = tclvalue(subsetVariable))) if (length(response) == 0 || length(predictor1) == 0 || length(predictor2) == 0){ errorCondition(recall=StatMedROCtest, message=gettextRcmdr("You must select three variables.")) return() } closeDialog() command <- paste("ROC1 <- roc(", response, "~", predictor1, ", data=", subset1, ActiveDataSet(), subset2, ", ci=TRUE)", sep="") doItAndPrint(command) command <- paste("ROC2 <- roc(", response, "~", predictor2, ", data=", subset1, ActiveDataSet(), subset2, ", ci=TRUE)", sep="") doItAndPrint(command) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("plot(ROC1, lty=1)") doItAndPrint("plot(ROC2, lty=2, add=TRUE)") doItAndPrint(paste('legend("bottomright", c("', predictor1, '", "', predictor2, '"), lty=1:2, box.lty=0)', sep="")) command <- paste("(res <- roc.test(", response, "~", predictor1, "+", predictor2, ", data=", subset1, ActiveDataSet(), subset2, "))", sep="") doItAndPrint(command) doItAndPrint("roc.table <- signif(cbind(res$estimate, res$p.value), digits=3)") doItAndPrint(paste('rownames(roc.table) <- c("', predictor1, '", "', predictor2, '")', sep="")) doItAndPrint('colnames(roc.table) <- gettextRcmdr(c("Area under the curve", "p.value"))') doItAndPrint('roc.table[2,2] <- ""') doItAndPrint("data.frame(roc.table)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="roc.test", apply="StatMedROCtest", reset="StatMedROCtest") tkgrid(getFrame(responseBox), labelRcmdr(variablesFrame, text=" "), sticky="nw") tkgrid(getFrame(predictor1Box), labelRcmdr(variables2Frame, text=" "), getFrame(predictor2Box), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(variables2Frame, sticky="nw") StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedSurvivalROC <- function(){ defaults <- list(event = "", timetoevent = "", predictor=NULL, method="0", point = "<none>", span = "0.05", subset = "") dialog.values <- getDialog("StatMedSurvivalROC", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("ROC curve analysis for time-to-event data")) variablesFrame <- tkframe(top) eventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Status indicator (censor=0, event=1) (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$event, "all")) timetoeventBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Time-to-event variable (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$timetoevent, "all")) variables2Frame <- tkframe(top) predictorBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Predictor (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$predictor, "all")) optionFrame <- tkframe(top) pointFrame <- tkframe(optionFrame) pointVariable <- tclVar(dialog.values$point) pointField <- ttkentry(pointFrame, width="20", textvariable=pointVariable) radioButtons(optionFrame, name="method", buttons=c("KM", "NNE"), values=c("0", "1"), initialValue=dialog.values$method, labels=gettextRcmdr(c("Kaplan-Meier", "Nearest neighbor estimation")), title=gettextRcmdr("Method")) spanFrame <- tkframe(optionFrame) spanVariable <- tclVar(dialog.values$span) spanField <- ttkentry(spanFrame, width="20", textvariable=spanVariable) onOK <- function(){ logger(paste("#####", gettextRcmdr("ROC curve analysis for time-to-event data"), "#####", sep="")) event <- getSelection(eventBox) timetoevent <- getSelection(timetoeventBox) predictor <- getSelection(predictorBox) method <- as.character(tclvalue(methodVariable)) subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>") || trim.blanks(subset) == ""){ dataSet <- activeDataSet() } else{ dataSet <- paste("subset(", activeDataSet(), ", ", subset, ")", sep="") } point <- tclvalue(pointVariable) span <- tclvalue(spanVariable) putDialog("StatMedSurvivalROC", list(event = event, timetoevent = timetoevent, predictor = predictor, method = method, point = tclvalue(pointVariable), span = span, subset = tclvalue(subsetVariable))) if (length(event) != 1) { errorCondition(recall=StatMedSurvivalROC, message=gettextRcmdr("Pick one status indicator (censor=0, event=1)")) return() } if (length(timetoevent) != 1) { errorCondition(recall=StatMedSurvivalROC, message=gettextRcmdr("Pick one time-to-event variable")) return() } if (length(predictor) != 1) { errorCondition(recall=StatMedSurvivalROC, message=gettextRcmdr("Pick one predictor variable")) return() } if (point == "<none>") { errorCondition(recall=StatMedSurvivalROC, message=gettextRcmdr("Define time to evaluate survival rate")) return() } closeDialog() Library("survival") Library("survivalROC") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", paste(substring(get("par.option", envir=.GlobalEnv), 1, nchar(get("par.option", envir=.GlobalEnv))-8), "2.5,1,0)", sep=""), ")", sep=""))} if(method=="0"){ doItAndPrint(paste("ROC <- survivalROC(", dataSet, "$", timetoevent, ", ", dataSet, "$", event, ", ", dataSet, "$", predictor, ", predict.time=", point, ', method="KM")', sep="")) } else { doItAndPrint(paste("ROC <- survivalROC(", dataSet, "$", timetoevent, ", ", dataSet, "$", event, ", ", dataSet, "$", predictor, ", predict.time=", point, ', method="NNE", span=', span, ")", sep="")) } doItAndPrint('plot(1-ROC$FP, ROC$TP, type="l", xlim=c(1,0), ylim=c(0,1), xlab="Specificity", ylab="Sensitivity", main=paste("AUC = ", round(ROC$AUC,3), sep=""))') doItAndPrint("abline(1,-1)") doItAndPrint("maxSensSpec <- max(1-ROC$FP + ROC$TP)") doItAndPrint("maxThre <- ROC$cut.values[1-ROC$FP+ROC$TP==maxSensSpec]") doItAndPrint("sensmaxThre <- round(ROC$TP[1-ROC$FP+ROC$TP==maxSensSpec], 3)") doItAndPrint("specmaxThre <- round(1-ROC$FP[1-ROC$FP+ROC$TP==maxSensSpec], 3)") doItAndPrint("res <- cbind(ROC$cut.values, 1-ROC$FP, ROC$TP)") doItAndPrint('colnames(res) <- c("threshold", "specificity", "sensitivity")') doItAndPrint("res") doItAndPrint('cat(paste(gettextRcmdr( "Threshold to maximize the sum of sensitivity and specificity"), " = ", maxThre, "\n", sep=""))') doItAndPrint('cat(paste(gettextRcmdr("Sensitivity"), " = ", sensmaxThre, ", ", gettextRcmdr( "Specificity"), " = ", specmaxThre, "\n", sep=""))') } OKCancelHelp(helpSubject="survivalROC", model=TRUE, apply="StatMedSurvivalROC", reset="StatMedSurvivalROC") tkgrid(getFrame(timetoeventBox), labelRcmdr(variablesFrame, text=" "), getFrame(eventBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(predictorBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(labelRcmdr(pointFrame, text=gettextRcmdr("Time point to evaluate survival rate")), pointField, sticky = "w") tkgrid(labelRcmdr(spanFrame, text=gettextRcmdr("Span for nearest neighbor estimation")), spanField, sticky = "w") tkgrid(pointFrame, labelRcmdr(optionFrame, text=" "), methodFrame, labelRcmdr(optionFrame, text=" "), spanFrame, sticky="w") tkgrid(optionFrame, sticky="w") StatMedSubsetBox(model=TRUE) tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedTest <- function(){ initializeDialog(title=gettextRcmdr("Accuracy of qualitative test")) textFrame <- tkframe(top) variableFrame <- tkframe(top) pospos <- tclVar("") posposEntry <- ttkentry(variableFrame, width="10", textvariable=pospos) posneg <- tclVar("") posnegEntry <- ttkentry(variableFrame, width="10", textvariable=posneg) variable2Frame <- tkframe(top) negpos <- tclVar("") negposEntry <- ttkentry(variable2Frame, width="10", textvariable=negpos) negneg <- tclVar("") negnegEntry <- ttkentry(variable2Frame, width="10", textvariable=negneg) onOK <- function(){ logger(paste("#####", gettextRcmdr("Accuracy of qualitative test"), "#####", sep="")) pospos <- tclvalue(pospos) posneg <- tclvalue(posneg) negpos <- tclvalue(negpos) negneg <- tclvalue(negneg) closeDialog() if (length(pospos) == 0 || length(posneg) == 0 || length(negpos) == 0 || length(negneg) == 0){ errorCondition(recall=StatMedTest, message=gettextRcmdr("You must select a variable.")) return() } # library(epiR, quietly=TRUE) # command <- paste("res <- epi.tests(", pospos, ", ", posneg, ", ", negpos, ", ", negneg, ", conf.level = 0.95)", sep="") # result <- doItAndPrint(command) # doItAndPrint("summary.test <- round(rbind(res$se, res$sp, res$ppv, res$npv, res$da, res$lr.pos, res$lr.neg), 3)") # doItAndPrint('rownames(summary.test) <- c("Sensitivity", "Specificity", "Positive predictive value", "Negative predictive value", "Diagnstic accuracy", "Likelihood ratio of a positive test", "Likelihood ratio of a negative test")') # doItAndPrint('colnames(summary.test) <- c("Estimation", "Lower 95%CI", "Upper 95%CI")') doItAndPrint(paste(".Table <- matrix(c(", pospos, ", ", posneg, ", ", negpos, ", ", negneg, "), 2, 2, byrow=TRUE)", sep="")) # doItAndPrint('colnames(.Table) <- gettextRcmdr(c("Disease positive", "Disease negative"))') # doItAndPrint('rownames(.Table) <- gettextRcmdr(c("Test positive", "Test negative"))') # doItAndPrint(".Table") command <- "epi.tests(.Table, conf.level = 0.95)" doItAndPrint(command) # doItAndPrint("summary.test") # doItAndPrint("remove(summary.test)") # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="epi.tests") tkgrid(labelRcmdr(textFrame, text=gettextRcmdr("Number Disease (+) (-)")), sticky="w") tkgrid(textFrame, sticky="w") tkgrid(tklabel(variableFrame, text=paste(gettextRcmdr("Test (+)"), " ", sep="")), posposEntry, posnegEntry, sticky="w") tkgrid(tklabel(variable2Frame, text=paste(gettextRcmdr("Test (-)"), " ", sep="")), negposEntry, negnegEntry, sticky="w") tkgrid.configure(posposEntry, sticky="w") tkgrid.configure(posnegEntry, sticky="w") tkgrid.configure(negposEntry, sticky="w") tkgrid.configure(negnegEntry, sticky="w") tkgrid(variableFrame, sticky="nw") tkgrid(variable2Frame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedPredictiveValue <- function(){ initializeDialog(title=gettextRcmdr("Compute positive and negative predictive values")) preprob <- tclVar("") preprobEntry <- ttkentry(top, width="20", textvariable=preprob) sens <- tclVar("") sensEntry <- ttkentry(top, width="20", textvariable=sens) spec <- tclVar("") specEntry <- ttkentry(top, width="20", textvariable=spec) onOK <- function(){ logger(paste("#####", gettextRcmdr("Compute positive and negative predictive values"), "#####", sep="")) preprob <- as.numeric(tclvalue(preprob)) sens <- as.numeric(tclvalue(sens)) spec <- as.numeric(tclvalue(spec)) closeDialog() if (length(preprob) == 0 || length(sens) == 0 || length(spec) == 0){ errorCondition(recall=StatMedPredictiveValue, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("x <- seq(0, 1, 0.01)") doItAndPrint(paste("plot(x, x*", sens, "/(x*", sens, "+(1-x)*(1-", spec, ')), ylim=c(0,1), type="l", ylab="Predictive value", xlab="Pretest probability")', sep="")) doItAndPrint("par(new=T)") doItAndPrint(paste("plot(x, (1-x)*", spec, "/(x*(1-", sens, ")+(1-x)*", spec, '), ylim=c(0,1), type="l", lty=2, ylab="", xlab="", col.axis=0)', sep="")) doItAndPrint('legend("bottom", c("Positive predictive value", "Negative predictive value"), lty=1:2, box.lty=0)') doItAndPrint(paste("PPT <- ", preprob, "*", sens, "/(", preprob, "*", sens, "+(1-", preprob, ")*(1-", spec, "))", sep="")) doItAndPrint(paste("NPT <- (1-", preprob, ")*", spec, "/(", preprob, "*(1-", sens, ")+(1-", preprob, ")*", spec, ")", sep="")) doItAndPrint(paste("predictive.value <- data.frame(c(", preprob, ", ", sens, ", ", spec, ', " ", gettextRcmdr("Estimated"), round(PPT, 3), round(NPT,3)))', sep="")) doItAndPrint('colnames(predictive.value) <- gettextRcmdr("Assumptions")') doItAndPrint('rownames(predictive.value) <- gettextRcmdr(c("Pretest probability", "Sensitivity", "Specificity", " ", " ", "Positive predictive value", "Negative predictive value"))') doItAndPrint("predictive.value") doItAndPrint("remove(predictive.value)") tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Pretest probability")), preprobEntry, sticky="w") tkgrid.configure(preprobEntry, sticky="w") tkgrid(tklabel(top, text=paste(gettextRcmdr("Sensitivity"), "(0-1)", sep="")), sensEntry, sticky="w") tkgrid.configure(sensEntry, sticky="w") tkgrid(tklabel(top, text=paste(gettextRcmdr("Specificity"), "(0-1)", sep="")), specEntry, sticky="w") tkgrid.configure(specEntry, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedKappa <- function(){ initializeDialog(title=gettextRcmdr("Kappa statistics for agreement of two tests")) textFrame <- tkframe(top) variableFrame <- tkframe(top) variableFrame <- tkframe(top) pospos <- tclVar("") posposEntry <- ttkentry(variableFrame, width="10", textvariable=pospos) posneg <- tclVar("") posnegEntry <- ttkentry(variableFrame, width="10", textvariable=posneg) variable2Frame <- tkframe(top) negpos <- tclVar("") negposEntry <- ttkentry(variable2Frame, width="10", textvariable=negpos) negneg <- tclVar("") negnegEntry <- ttkentry(variable2Frame, width="10", textvariable=negneg) onOK <- function(){ logger(paste("#####", gettextRcmdr("Kappa statistics for agreement of two tests"), "#####", sep="")) pospos <- tclvalue(pospos) posneg <- tclvalue(posneg) negpos <- tclvalue(negpos) negneg <- tclvalue(negneg) closeDialog() if (length(pospos) == 0 || length(posneg) == 0 || length(negpos) == 0 || length(negneg) == 0){ errorCondition(recall=StatMedKappa, message=gettextRcmdr("You must select a variable.")) return() } # library(epiR, quietly=TRUE) doItAndPrint(".Table <- NULL") doItAndPrint(paste(".Table <- matrix(c(", pospos, ", ", posneg, ", ", negpos, ", ", negneg, "), 2, 2, byrow=TRUE)", sep="")) doItAndPrint('colnames(.Table) <- gettextRcmdr(c("Test2 (+)", "Test2 (-)"))') doItAndPrint('rownames(.Table) <- gettextRcmdr(c("Test1 (+)", "Test1 (-)"))') doItAndPrint(".Table") command <- "res <- epi.kappa(.Table, conf.level = 0.95)" doItAndPrint("res <- NULL") doItAndPrint(command) # doItAndPrint("remove(.Table)") doItAndPrint('colnames(res$kappa) <- gettextRcmdr( colnames(res$kappa))') # doItAndPrint('colnames(res$mcnemar) <- gettextRcmdr( colnames(res$mcnemar))') doItAndPrint("res[1]") # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="epi.kappa") tkgrid(labelRcmdr(textFrame, text=gettextRcmdr("Number Test2 (+) (-)")), sticky="w") tkgrid(textFrame, sticky="w") tkgrid(tklabel(variableFrame, text=paste(gettextRcmdr("Test1 (+)"), " ", sep="")), posposEntry, posnegEntry, sticky="w") tkgrid(tklabel(variable2Frame, text=paste(gettextRcmdr("Test1 (-)"), " ", sep="")), negposEntry, negnegEntry, sticky="w") tkgrid.configure(posposEntry, sticky="w") tkgrid.configure(posnegEntry, sticky="w") tkgrid.configure(negposEntry, sticky="w") tkgrid.configure(negnegEntry, sticky="w") tkgrid(variableFrame, sticky="nw") tkgrid(variable2Frame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedReliability <- function(){ defaults <- list(x=NULL) dialog.values <- getDialog("StatMedReliability", defaults) initializeDialog(title=gettextRcmdr("Cronbach's alpha coefficient for reliability")) xBox <- variableListBox(top, Numeric(), selectmode="multiple", title=gettextRcmdr("Variables (pick three or more)"), initialSelection=varPosn(dialog.values$x, "numeric")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Cronbach's alpha coefficient for reliability"), "#####", sep="")) x <- getSelection(xBox) putDialog("StatMedReliability", list(x=x)) closeDialog() if (3 > length(x)) { errorCondition(recall=StatMedReliability, message=gettextRcmdr("Fewer than 3 variables selected.")) return() } x <- paste('"', x, '"', sep="") doItAndPrint("res <- NULL") doItAndPrint(paste("res <- reliability(cov(", ActiveDataSet(), "[,c(", paste(x, collapse=","), ')], use="complete.obs"))', sep="")) doItAndPrint("res$rel.matrix <- signif(res$rel.matrix, digits=4)") doItAndPrint('colnames(res$rel.matrix) <- gettextRcmdr( c("Alpha reliability", "Standardized alpha", "r(item, total)"))') doItAndPrint("res$rel.matrix <- cbind(rownames(res$rel.matrix), res$rel.matrix)") doItAndPrint("rownames(res$rel.matrix) <- NULL") doItAndPrint('colnames(res$rel.matrix)[1] <- gettextRcmdr("Deleted item")') doItAndPrint('cat("\n", gettextRcmdr("Alpha reliability"), "=", signif(res$alpha, digits=4), ", ", gettextRcmdr("Standardized alpha"), "=", signif(res$st.alpha, digits=4), "\n\n", gettextRcmdr("Reliability deleting each item in turn:"), "\n\n"); data.frame(res$rel.matrix)') # doItAndPrint("res$rel.matrix") # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="reliability", apply="StatMedReliability", reset="StatMedReliability") tkgrid(getFrame(xBox), sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=2, columns=1) } StatMedMatching <- function(){ defaults <- list(group=NULL, strata=NULL, matchnumber="1", caliper="TRUE", calipervalue=0.2, newDataSetName="Add _MP at the end of original name") dialog.values <- getDialog("StatMedMatching", defaults) dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Extract matched controls")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable (control=0, case=1) (pick one)"), listHeight=15, initialSelection=varPosn(dialog.values$group, "all")) strataBox <- variableListBox(variablesFrame, Variables(),selectmode="multiple", title=gettextRcmdr("Matching variables (pick at least one)"), listHeight=15, initialSelection=varPosn(dialog.values$strata, "all")) # newDataSetName <- tclVar(gettextRcmdr("Add _MP at the end of original name")) dataSetNameFrame <- tkframe(top) dataSetName <- tclVar(gettextRcmdr(dialog.values$newDataSetName)) dataSetNameField <- ttkentry(dataSetNameFrame, width="25", textvariable=dataSetName) optionsFrame <- tkframe(top) matchnumberFrame <- tkframe(optionsFrame) matchnumberLevel <- tclVar(dialog.values$matchnumber) matchnumberField <- ttkentry(matchnumberFrame, width="6", textvariable=matchnumberLevel) calipervalueFrame <- tkframe(optionsFrame) calipervalueLevel <- tclVar(dialog.values$calipervalue) calipervalueField <- ttkentry(calipervalueFrame, width="6", textvariable=calipervalueLevel) onOK <- function(){ logger(paste("#####", gettextRcmdr("Extract matched controls"), "#####", sep="")) group <- getSelection(groupBox) strata <- getSelection(strataBox) matchnumber <- tclvalue(matchnumberLevel) calipervalue <- tclvalue(calipervalueLevel) caliper <- as.character(tclvalue(caliperVariable)) if(caliper=="FALSE"){ caliper <- "NULL" } else { caliper <- calipervalue } newName <- trim.blanks(tclvalue(dataSetName)) if (newName == gettextRcmdr("Add _MP at the end of original name")) newName <- paste(ActiveDataSet(), "_MP", sep="") putDialog("StatMedMatching", list(group=group, strata=strata, matchnumber=matchnumber, caliper=caliper, calipervalue=calipervalue, newDataSetName=newName)) if (length(group) == 0) { errorCondition(recall=StatMedMatching, message=gettextRcmdr("You must select a groups variable.")) return() } if (length(strata) == 0) { errorCondition(recall=StatMedMatching, message=gettextRcmdr("Pick at least one matching variable")) return() } if (!is.valid.name(newName)){ errorCondition(recall=StatMedMatching, message=paste('"', newName, '" ', gettextRcmdr("is not a valid name."), sep="")) return() } if (is.element(newName, listDataSets())) { if ("no" == tclvalue(checkReplace(newName, type=gettextRcmdr("Data set")))){ closeDialog() StatMedMatching() return() } } closeDialog() .activeDataSet <- ActiveDataSet() doItAndPrint("library(Matching, quietly=TRUE)") nacheck.command <- paste("TempDataSet <- ", .activeDataSet, "[complete.cases(", .activeDataSet, "$", group, ", ", .activeDataSet, "$", strata[1], sep="") strata2 <- paste("cbind(TempDataSet$", strata[1], sep="") if (length(strata) >1 ){ for (i in 2:length(strata)){ nacheck.command <- paste(nacheck.command, ", ", .activeDataSet, "$", strata[i], sep="") strata2 <- paste(strata2, ", TempDataSet$", strata[i], sep="") } } strata2 <- paste(strata2, ")", sep="") strata <- strata2 nacheck.command <- paste(nacheck.command, "),]", sep="") doItAndPrint(nacheck.command) match.command <- paste("match.results <- Match(Tr=TempDataSet$", group, ", X=", strata, ", M=", matchnumber, ", caliper=", caliper, ", replace=FALSE)", sep="") logger(match.command) result <- justDoIt(match.command) if (class(result)[1] == "try-error"){ errorCondition(recall=StatMedMatching, message=gettextRcmdr("Matching failed")) return() } doItAndPrint("summary(match.results)") if(matchnumber>1){ doItAndPrint(paste("match.results$index.treated <- match.results$index.treated[", matchnumber, " * (1:(length(match.results$index.treated)/", matchnumber, "))]", sep="")) } doItAndPrint("pairmatch.treated <- 1:length(match.results$index.treated)") doItAndPrint(paste("pairmatch.control <- rep(pairmatch.treated, each=", matchnumber, ")", sep="")) doItAndPrint("pairmatch <- c(pairmatch.treated, pairmatch.control)") command <- paste(newName, " <- rbind(TempDataSet[match.results$index.treated,], TempDataSet[match.results$index.control,])", sep="") logger(command) result <- justDoIt(command) doItAndPrint(paste(newName, "$pairmatch <- pairmatch", sep="")) if (class(result)[1] != "try-error") activeDataSet(newName) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Match", apply="StatMedMatching", reset="StatMedMatching") tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(groupBox), labelRcmdr(variablesFrame, text=" "), getFrame(strataBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(matchnumberFrame, text=gettextRcmdr("Number of controls matched to one case"), fg="blue"), sticky="w") tkgrid(matchnumberField, sticky="w") tkgrid(labelRcmdr(calipervalueFrame, text=gettextRcmdr("Caliper width"), fg="blue"), sticky="w") tkgrid(calipervalueField, sticky="w") radioButtons(optionsFrame, name="caliper", buttons=c("FALSE", "TRUE"), values=c("FALSE", "TRUE"), initialValue=dialog.values$caliper, labels=gettextRcmdr(c("No", "Yes")), title=gettextRcmdr("Caliper matching")) tkgrid(matchnumberFrame, labelRcmdr(optionsFrame, text=" "), caliperFrame, labelRcmdr(optionsFrame, text=" "), calipervalueFrame, sticky="nw") tkgrid(optionsFrame, sticky="nw") options2Frame <- tkframe(top) tkgrid(labelRcmdr(options2Frame, text=gettextRcmdr("Caliper width as a proportion of standard deviation, applied for all variables"), fg="blue"), sticky="w") tkgrid(options2Frame, sticky="nw") tkgrid(labelRcmdr(dataSetNameFrame, text=gettextRcmdr("Name for new data set")), sticky="w") tkgrid(dataSetNameField, sticky="w") tkgrid(dataSetNameFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedMH <- function(){ defaults <- list(group=NULL, var=NULL, strata=NULL, continuity="TRUE") dialog.values <- getDialog("StatMedMH", defaults) dataSet <- activeDataSet() initializeDialog(title=gettextRcmdr("Mantel-Haenzel test for matched proportions")) variablesFrame <- tkframe(top) groupBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Grouping variable (control=0, case=1) (pick one)"), listHeight=8, initialSelection=varPosn(dialog.values$group, "all")) varBox <- variableListBox(variablesFrame, Variables(),selectmode="multiple", title=gettextRcmdr("Binary response variable (pick at least one)"), listHeight=8, initialSelection=varPosn(dialog.values$var, "all")) variables2Frame <- tkframe(top) strataBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Stratifying variable for matching (pairmatch)"), listHeight=8, initialSelection=varPosn(dialog.values$strata, "all")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Mantel-Haenzel test for matched proportions"), "#####", sep="")) group <- getSelection(groupBox) var <- getSelection(varBox) strata <- getSelection(strataBox) continuity <- tclvalue(continuityVariable) putDialog("StatMedMH", list(group=group, var=var, strata=strata, continuity=continuity)) if (length(group) == 0) { errorCondition(recall=StatMedMH, message=gettextRcmdr("You must select a groups variable.")) return() } if (length(var) == 0) { errorCondition(recall=StatMedMH, message=gettextRcmdr("Pick at least one binary response variable.")) return() } if (length(strata) == 0) { errorCondition(recall=StatMedMH, message=gettextRcmdr("")) return() } closeDialog() .activeDataSet <- ActiveDataSet() nvar = length(var) doItAndPrint("MH.summary.table <- NULL") for (i in 1:nvar) { if (var[i] == group) { errorCondition(recall=StatMedMH, message=gettextRcmdr("Row and column variables are the same.")) return() } command <- paste("xtabs(~", var[i], "+", group, ", data=", .activeDataSet, ")", sep="") # logger(paste(".Table <- ", command, sep="")) # assign(".Table", justDoIt(command), envir=.GlobalEnv) doItAndPrint(".Table <- NULL") doItAndPrint(paste(".Table <- ", command, sep="")) doItAndPrint(".Table") doItAndPrint("res <- NULL") command <- paste("(res <- mantelhaen.test(", .activeDataSet, "$", group, ", ", .activeDataSet, "$", var[i], ", ", .activeDataSet, "$", strata, ", correct=", continuity, "))", sep="") doItAndPrint(command) doItAndPrint("MH.summary.table <- rbind(MH.summary.table, summary.table.MH(table=.Table, res=res))") # doItAndPrint("remove(res)") } doItAndPrint("MH.summary.table") # doItAndPrint("remove(MH.summary.table)") # logger("remove(.Table)") # remove(.Table, envir=.GlobalEnv) tkfocus(CommanderWindow()) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="mantelhaen.test", apply="StatMedMH", reset="StatMedMH") tkgrid(labelRcmdr(variablesFrame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(groupBox), labelRcmdr(variablesFrame, text=" "), getFrame(varBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(strataBox), labelRcmdr(variables2Frame, text=" "), sticky="nw") tkgrid(variables2Frame, sticky="nw") analysisFrame <- tkframe(top) radioButtons(analysisFrame, name="continuity", buttons=c("yes", "no"), values=c("TRUE", "FALSE"), initialValue=dialog.values$continuity, labels=gettextRcmdr(c("Yes", "No")), title=gettextRcmdr("Continuity correction of chi-square test")) tkgrid(continuityFrame, sticky="w") tkgrid(analysisFrame, sticky="nw") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedCLogistic <- function(){ defaults <- list(lhs = "", rhs = "", actmodelVariable = 0, strata = NULL) dialog.values <- getDialog("StatMedCLogistic", defaults) currentFields$lhs <- dialog.values$lhs currentFields$rhs <- dialog.values$rhs currentFields$subset <- dialog.values$subset # initializeDialog(title=gettextRcmdr("Generalized Linear Model")) initializeDialog(title=gettextRcmdr("Conditional logistic regression for matched-pair analysis")) .activeModel <- ActiveModel() currentModel <- if (!is.null(.activeModel)) class(get(.activeModel, envir=.GlobalEnv))[1] == "glm" # eval(parse(text=paste("class(", .activeModel, ")[1] == 'glm'", sep="")), # envir=.GlobalEnv) else FALSE if (currentModel) { currentFields <- formulaFields(get(.activeModel, envir=.GlobalEnv), glm=TRUE) # currentFields <- formulaFields(eval(parse(text=.activeModel), # envir=.GlobalEnv), glm=TRUE) if (currentFields$data != ActiveDataSet()) currentModel <- FALSE } currentModel <- TRUE StatMedModelFormula() variables2Frame <- tkframe(top) strataBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Stratifying variable for matching (pairmatch)"), listHeight=8, initialSelection=varPosn(dialog.values$strata, "all")) UpdateModelNumber() modelName <- tclVar(paste("GLM.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="20", textvariable=modelName) optionsFrame <- tkframe(top) checkBoxes(frame="checkboxFrame", boxes=c("actmodel"), initialValues=c(dialog.values$actmodelVariable),labels=gettextRcmdr(c("Keep results as active model for further analyses"))) # actmodelVariable <- tclVar("0") # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) # stepwise1Variable <- tclVar("0") # stepwise1CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise1Variable) # stepwise2Variable <- tclVar("0") # stepwise2CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise2Variable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Conditional logistic regression for matched-pair analysis"), "#####", sep="")) strata <- getSelection(strataBox) modelValue <- trim.blanks(tclvalue(modelName)) formula <- paste(tclvalue(lhsVariable), " ~ ", tclvalue(rhsVariable), " + strata(", strata, ")", sep="") actmodel <- tclvalue(actmodelVariable) # stepwise1 <- tclvalue(stepwise1Variable) # stepwise2 <- tclvalue(stepwise2Variable) putDialog("StatMedCLogistic", list(lhs = tclvalue(lhsVariable), rhs = tclvalue(rhsVariable), actmodelVariable = actmodel, strata = strata)) closeDialog() check.empty <- gsub(" ", "", tclvalue(lhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedCLogistic, model=TRUE, message=gettextRcmdr("Left-hand side of model empty.")) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedCLogistic, model=TRUE, message=gettextRcmdr("Right-hand side of model empty.")) return() } if (length(strata) == 0) { errorCondition(recall=StatMedCLogistic, message=gettextRcmdr("Pick one stratifying variable for matching.")) return() } if (!is.valid.name(modelValue)){ errorCondition(recall=StatMedCLogistic, model=TRUE, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue)) return() } if (is.element(modelValue, listGeneralizedLinearModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) closeDialog() StatMedCLogistic() return() } } Library("survival") command <- paste("clogit(", formula, ", data=", ActiveDataSet(), ")", sep="") # logger(paste(modelValue, " <- ", command, sep="")) # assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(modelValue, " <- ", command, sep="")) doItAndPrint("res <- NULL") doItAndPrint(paste("(res <- summary(", modelValue, "))", sep="")) doItAndPrint("odds <- NULL") if(eval(parse(text="length(res$coefficients[,1])"))==1){ doItAndPrint(paste("odds <- signif(c(res$conf.int[,c(1,3,4)], res$coefficients[,5]), digits=4)", sep="")) doItAndPrint("odds <- t(odds)") doItAndPrint("rownames(odds) <- rownames(res$coefficients)") } else { doItAndPrint(paste("odds <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,5]), digits=4)", sep="")) } doItAndPrint("odds <- data.frame(odds)") doItAndPrint("odds <- signif(odds, digits=3)") doItAndPrint('names(odds) <- gettextRcmdr(c("odds ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') doItAndPrint("odds") # if (stepwise1 == 1 | stepwise2 == 1){ # x <- strsplit(tclvalue(rhsVariable), split="\\+") # command <- paste("TempDF <- with(", ActiveDataSet(), ", ", ActiveDataSet(), "[complete.cases(", paste(x[[1]], collapse=","), "),])", sep="") # doItAndPrint(command) # command <- paste("clogit(", formula, ", data=TempDF)", sep="") # doItAndPrint(paste(modelValue, " <- ", command, sep="")) # } # if (stepwise1 == 1){ # doItAndPrint("odds <- data.frame(exp( summary(res)$coef[,1:2] %*% rbind(c(1,1,1), 1.96*c(0,-1,1))))") # doItAndPrint(paste("odds <- cbind(odds, summary(res)$coefficients[,4])", sep="")) # doItAndPrint("odds <- signif(odds, digits=3)") # doItAndPrint('names(odds) <- c("odds ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') # doItAndPrint("summary(res)") # doItAndPrint("odds") # doItAndPrint("remove(res)") # } # if (stepwise2 == 1){ # doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="BIC")', sep="")) # doItAndPrint("odds <- data.frame(exp( summary(res)$coef[,1:2] %*% rbind(c(1,1,1), 1.96*c(0,-1,1))))") # doItAndPrint(paste("odds <- cbind(odds, summary(res)$coefficients[,4])", sep="")) # doItAndPrint("odds <- signif(odds, digits=3)") # doItAndPrint('names(odds) <- c("odds ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') # doItAndPrint("summary(res)") # doItAndPrint("odds") # doItAndPrint("remove(res)") # } # doItAndPrint("remove(odds)") # doItAndPrint("remove(res)") if (actmodel==1) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="clogit", apply="StatMedCLogistic", reset="StatMedCLogistic") helpButton <- buttonRcmdr(buttonsFrame, text="Help", width="12", command=onHelp) tkgrid(labelRcmdr(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") tkgrid(getFrame(xBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(getFrame(strataBox), labelRcmdr(variables2Frame, text=" "), sticky="nw") tkgrid(variables2Frame, sticky="nw") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on AIC")), stepwise1CheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on BIC")), stepwise2CheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on AIC/BIC not performed when missing data included.")), sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(checkboxFrame, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Keep results as active model for further analyses")), actmodelCheckBox, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } StatMedStCox <- function(){ xx <- getRcmdr("modelClasses") bolCoxphExists = FALSE for(ii in 1:length(xx)){if (xx[ii] == "coxph") bolCoxphExists = TRUE} if (bolCoxphExists == FALSE) putRcmdr("modelClasses", c(getRcmdr("modelClasses"), "coxph")) defaults <- list(SurvivalTimeVariable = "", StatusVariable = "", rhs = "", waldVariable = 0, prophazVariable = 0, basecurveVariable = 0, actmodelVariable = 0, stepwise1Variable = 0, stepwise2Variable = 0, stepwise3Variable = 0, strata = NULL) dialog.values <- getDialog("StatMedStCox", defaults) currentFields$SurvivalTimeVariable <- dialog.values$SurvivalTimeVariable currentFields$StatusVariable <- dialog.values$StatusVariable currentFields$rhs <- dialog.values$rhs initializeDialog(title=gettextRcmdr("Stratified Cox proportional hazard regression for matched-pair analysis")) .activeModel <- ActiveModel() currentModel <- if (!is.null(.activeModel)) class(get(.activeModel, envir=.GlobalEnv))[1] == "coxph" # eval(parse(text=paste("class(", .activeModel, ")[1] == 'coxph'", sep="")), # envir=.GlobalEnv) else FALSE currentModel <- TRUE # if(currentModel){ # currentFields <- formulaFields(eval(parse(text=.activeModel), # envir=.GlobalEnv)) # if (currentFields$data != ActiveDataSet()) currentModel <- FALSE # } variables2Frame <- tkframe(top) strataBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Stratifying variable for matching (pairmatch)"), listHeight=8, initialSelection=varPosn(dialog.values$strata, "all")) UpdateModelNumber() modelName <- tclVar(paste("CoxModel.", getRcmdr("modelNumber"), sep="")) modelFrame <- tkframe(top) model <- ttkentry(modelFrame, width="30", textvariable=modelName) optionsFrame <- tkframe(top) checkBoxes(frame="checkboxFrame", boxes=c("wald", "prophaz", "actmodel", "stepwise1", "stepwise2"), initialValues=c(dialog.values$waldVariable, dialog.values$prophazVariable, dialog.values$actmodelVariable, dialog.values$stepwise1Variabl, dialog.values$stepwise2Variabl),labels=gettextRcmdr(c("Wald test for overall p-value for factors with >2 levels", "Test proportional hazards assumption", "Keep results as active model for further analyses", "Stepwise selection based on AIC", "Stepwise selection based on BIC"))) # waldVariable <- tclVar("0") # waldCheckBox <- tkcheckbutton(optionsFrame, variable=waldVariable) # prophazVariable <- tclVar("0") # prophazCheckBox <- tkcheckbutton(optionsFrame, variable=prophazVariable) # actmodelVariable <- tclVar("0") # actmodelCheckBox <- tkcheckbutton(optionsFrame, variable=actmodelVariable) # stepwise1Variable <- tclVar("0") # stepwise1CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise1Variable) # stepwise2Variable <- tclVar("0") # stepwise2CheckBox <- tkcheckbutton(optionsFrame, variable=stepwise2Variable) onOK <- function(){ logger(paste("#####", gettextRcmdr("Stratified Cox proportional hazard regression for matched-pair analysis"), "#####", sep="")) # XXX <- getSelection(timeBox) modelValue <- trim.blanks(tclvalue(modelName)) strata <- getSelection(strataBox) prophaz <- tclvalue(prophazVariable) wald <- tclvalue(waldVariable) actmodel <- tclvalue(actmodelVariable) stepwise1 <- tclvalue(stepwise1Variable) stepwise2 <- tclvalue(stepwise2Variable) # library(survival, quietly=TRUE) # formula <- paste("Surv(", XXX, ", ", tclvalue(lhsVariable), ") ~ ", tclvalue(rhsVariable), sep="") putDialog("StatMedStCox", list(SurvivalTimeVariable = tclvalue(SurvivalTimeVariable), StatusVariable = tclvalue(StatusVariable), rhs = tclvalue(rhsVariable), waldVariable = wald, prophazVariable = prophaz, actmodelVariable = actmodel, stepwise1Variable = stepwise1, stepwise2Variable = stepwise2, strata = strata)) closeDialog() # check.empty <- gsub(" ", "", tclvalue(lhsVariable)) # if ("" == check.empty) { # errorCondition(recall=StatMedCoxRegression, # message=gettextRcmdr("Left-hand side of model empty."), model=TRUE) # return() # } check.empty <- gsub(" ", "", tclvalue(SurvivalTimeVariable)) if ("" == check.empty) { errorCondition(recall=StatMedStCox, message=gettextRcmdr("Survival time variable of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(StatusVariable)) if ("" == check.empty) { errorCondition(recall=StatMedStCox, message=gettextRcmdr("Status variable of model empty."), model=TRUE) return() } check.empty <- gsub(" ", "", tclvalue(rhsVariable)) if ("" == check.empty) { errorCondition(recall=StatMedStCox, message=gettextRcmdr("Right-hand side of model empty."), model=TRUE) return() } if (is.element(modelValue, listCoxModels())) { if ("no" == tclvalue(checkReplace(modelValue, type=gettextRcmdr("Model")))){ UpdateModelNumber(-1) StatMedCoxRegression() return() } } if (!is.valid.name(modelValue)){ errorCondition(recall=StatMedStCox, message=sprintf(gettextRcmdr('"%s" is not a valid name.'), modelValue), model=TRUE) return() } if (length(strata) == 0) { errorCondition(recall=StatMedStCox, message=gettextRcmdr("Pick one stratifying variable for matching.")) return() } Library("survival") Library("aod") formula <- paste("Surv(", tclvalue(SurvivalTimeVariable), ", ", tclvalue(StatusVariable), "==1)~ ", tclvalue(rhsVariable), " + strata(", strata, ")", sep="") command <- paste("coxph(", formula, ", data=", ActiveDataSet(), ', method="breslow")', sep="") # logger(paste(modelValue, " <- ", command, sep="")) # assign(modelValue, justDoIt(command), envir=.GlobalEnv) doItAndPrint(paste(modelValue, " <- ", command, sep="")) doItAndPrint(paste("summary(", modelValue, ")", sep="")) doItAndPrint("res <- NULL") doItAndPrint(paste("res <- ", command, sep="")) doItAndPrint("res <- summary(res)") # if(eval(parse(text="length(res$coefficients[,1])"))==1){ # doItAndPrint("cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,5]), digits=4)") # doItAndPrint(paste('rownames(cox.table) <- "', tclvalue(rhsVariable), '"', sep="")) # doItAndPrint('colnames(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') # } else { # doItAndPrint("cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,5]), digits=4)") # doItAndPrint("cox.table <- data.frame(cox.table)") # doItAndPrint('names(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') # } doItAndPrint("cox.table <- NULL") if(eval(parse(text="length(res$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res$conf.int[,c(1,3,4)]), p.value=res$coefficients[,length(res$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res$coefficients)") doItAndPrint('colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } else { doItAndPrint("cox.table <- signif(cbind(res$conf.int[,c(1,3,4)], res$coefficients[,length(res$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('colnames(cox.table) <- gettextRcmdr(c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value"))') } # doItAndPrint("cox.table <- signif(cox.table, digits=3)") doItAndPrint("cox.table") if (wald==1) doItAndPrint(paste("waldtest(", modelValue, ")", sep="")) if (prophaz == 1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} nvar <- (eval(parse(text="length(cox.table[,1])"))) mfrow <- paste("c(4,", ceiling(nvar/4), ")", sep="") switch(as.character(nvar), "1"=mfrow <- "c(1,1)", "2"=mfrow <- "c(2,1)", "3"=mfrow <- "c(2,2)", "4"=mfrow <- "c(2,2)", "5"=mfrow <- "c(3,2)", "6"=mfrow <- "c(3,2)", "7"=mfrow <- "c(3,3)", "8"=mfrow <- "c(3,3)", "9"=mfrow <- "c(3,3)", "10"=mfrow <- "c(4,3)", "11"=mfrow <- "c(4,3)", "12"=mfrow <- "c(4,3)" ) doItAndPrint(paste("oldpar <- par(oma=c(0,0,3,0), mfrow=", mfrow, ")", sep="")) doItAndPrint(paste("plot(cox.zph(", modelValue, "), df=2)", sep="")) doItAndPrint("par(oldpar)") doItAndPrint(paste("print(cox.zph(", modelValue, "))", sep="")) } if (stepwise1 == 1 | stepwise2 == 1){ x <- strsplit(tclvalue(rhsVariable), split="\\+") command <- paste("TempDF <- with(", ActiveDataSet(), ", ", ActiveDataSet(), "[complete.cases(", paste(x[[1]], collapse=","), "),])", sep="") doItAndPrint(command) command <- paste("coxph(", formula, ', data=TempDF, method="breslow")', sep="") doItAndPrint(paste(modelValue, " <- ", command, sep="")) } if (stepwise1 == 1){ doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="AIC")', sep="")) doItAndPrint("summary(res)") doItAndPrint("res2 <- summary(res)") if(eval(parse(text="length(res2$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res2$conf.int[,c(1,3,4)]), p.value=res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res2$coefficients)") doItAndPrint('colnames(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } else if(eval(parse(text="length(res2$coefficients[,1])"))>1){ doItAndPrint("cox.table <- signif(cbind(res2$conf.int[,c(1,3,4)], res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('names(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } if (wald==1) doItAndPrint("waldtest(res)") } if (stepwise2 == 1){ doItAndPrint(paste("res <- stepwise(", modelValue, ', direction="backward/forward", criterion="BIC")', sep="")) doItAndPrint("summary(res)") doItAndPrint("res2 <- summary(res)") if(eval(parse(text="length(res2$coefficients[,1])"))==1){ doItAndPrint("cox.table <- signif(cbind(t(res2$conf.int[,c(1,3,4)]), p.value=res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("rownames(cox.table) <- rownames(res2$coefficients)") doItAndPrint('colnames(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } else if(eval(parse(text="length(res2$coefficients[,1])"))>1){ doItAndPrint("cox.table <- signif(cbind(res2$conf.int[,c(1,3,4)], res2$coefficients[,length(res2$coefficients[1,])]), digits=4)") doItAndPrint("cox.table <- data.frame(cox.table)") doItAndPrint('names(cox.table) <- c("Hazard ratio", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("cox.table") } if (wald==1) doItAndPrint("waldtest(res)") } # doItAndPrint("remove(res)") # doItAndPrint("remove(cox.table)") if (actmodel==1) activeModel(modelValue) tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="coxph", model=TRUE, apply="StatMedStCox", reset="StatMedStCox") tkgrid(tklabel(modelFrame, text=gettextRcmdr("Enter name for model:")), model, sticky="w") tkgrid(modelFrame, sticky="w") # StatMedModelFormula() modelFormulaCox() tkgrid(getFrame(xBox), sticky="w") # tkgrid(getFrame(xBox), getFrame(timeBox), sticky="w") tkgrid(outerOperatorsFrame, sticky="w") tkgrid(formulaFrame, sticky="w") tkgrid(getFrame(strataBox), labelRcmdr(variables2Frame, text=" "), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(checkboxFrame, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Wald test for overall p-value for factors with >2 levels")), waldCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Test proportional hazards assumption")), prophazCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Keep results as active model for further analyses")), actmodelCheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on AIC")), stepwise1CheckBox, sticky="w") # tkgrid(labelRcmdr(optionsFrame, text=gettextRcmdr("Stepwise selection based on BIC")), stepwise2CheckBox, sticky="w") tkgrid(optionsFrame, sticky="w", columnspan=2) tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1, focus=lhsEntry, preventDoubleClick=TRUE) } StatMedSampleProportionsSingle <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size for comparison with specified proportion")) group1 <- tclVar("") group1Entry <- ttkentry(top, width="20", textvariable=group1) group2 <- tclVar("") group2Entry <- ttkentry(top, width="20", textvariable=group2) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) power <- tclVar("0.80") powerEntry <- ttkentry(top, width="20", textvariable=power) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) radioButtons(name="continuity", buttons=c("Yes", "No"), values=c(1, 0), labels=gettextRcmdr(c("Yes (or exact test)", "No correction")),title=gettextRcmdr("Continuity correction of chi-square test")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size for comparison with specified proportion"), "#####", sep="")) group1 <- tclvalue(group1) group2 <- tclvalue(group2) alpha <- tclvalue(alpha) power <- tclvalue(power) method <- tclvalue(methodVariable) continuity <- tclvalue(continuityVariable) closeDialog() if (length(group1) == 0 || length(group2) == 0){ errorCondition(recall=StatMedSampleProportionsSingle, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(power) == 0 ){ errorCondition(recall=StatMedSampleProportionsSingle, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleProportionSingleArm(", group1, ", ", group2, ", ", alpha, ", ", power, ", ", method, ", ", continuity, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Proportion (control)")), group1Entry, sticky="w") tkgrid.configure(group1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Proportion (test)")), group2Entry, sticky="w") tkgrid.configure(group2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Power (1 - beta error)")), powerEntry, sticky="w") tkgrid.configure(powerEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(continuityFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedPowerProportionsSingle <- function(){ initializeDialog(title=gettextRcmdr("Calculate power for comparison with specified proportion")) group1 <- tclVar("") group1Entry <- ttkentry(top, width="20", textvariable=group1) group2 <- tclVar("") group2Entry <- ttkentry(top, width="20", textvariable=group2) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) sample <- tclVar("") sampleEntry <- ttkentry(top, width="20", textvariable=sample) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) radioButtons(name="continuity", buttons=c("Yes", "No"), values=c(1, 0), labels=gettextRcmdr(c("Yes (or exact test)", "No correction")),title=gettextRcmdr("Continuity correction of chi-square test")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate power for comparison with specified proportion"), "#####", sep="")) group1 <- tclvalue(group1) group2 <- tclvalue(group2) alpha <- tclvalue(alpha) sample <- tclvalue(sample) method <- tclvalue(methodVariable) continuity <- tclvalue(continuityVariable) closeDialog() if (length(group1) == 0 || length(group2) == 0){ errorCondition(recall=StatMedPowerProportionsSingle, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(sample) == 0 ){ errorCondition(recall=StatMedPowerProportionsSingle, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("PowerProportionSingleArm(", group1, ", ", group2, ", ", alpha, ", ", sample, ", ", method, ", ", continuity, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Proportion (control)")), group1Entry, sticky="w") tkgrid.configure(group1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Proportion (test)")), group2Entry, sticky="w") tkgrid.configure(group2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size")), sampleEntry, sticky="w") tkgrid.configure(sampleEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(continuityFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleProportionsCI <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size from proportion and confidence interval")) p1 <- tclVar("") p1Entry <- ttkentry(top, width="20", textvariable=p1) delta <- tclVar("") deltaEntry <- ttkentry(top, width="20", textvariable=delta) ci <- tclVar("95") ciEntry <- ttkentry(top, width="20", textvariable=ci) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size from proportion and confidence interval"), "#####", sep="")) p1 <- tclvalue(p1) delta <- tclvalue(delta) ci <- tclvalue(ci) closeDialog() if (length(p1) == 0 || length(delta) == 0 || length(ci) == 0){ errorCondition(recall=StatMedSampleProportionsCI, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleProportionCI(", p1, ", ", delta, ", ", ci, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Proportion")), p1Entry, sticky="w") tkgrid.configure(p1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Confidence interval width")), deltaEntry, sticky="w") tkgrid.configure(deltaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Confidence level")), ciEntry, sticky="w") tkgrid.configure(ciEntry, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleMeansCI <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size from standard deviation and confidence interval")) sd <- tclVar("") sdEntry <- ttkentry(top, width="20", textvariable=sd) delta <- tclVar("") deltaEntry <- ttkentry(top, width="20", textvariable=delta) ci <- tclVar("95") ciEntry <- ttkentry(top, width="20", textvariable=ci) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size from standard deviation and confidence interval"), "#####", sep="")) sd <- tclvalue(sd) delta <- tclvalue(delta) ci <- tclvalue(ci) closeDialog() if (length(sd) == 0 || length(delta) == 0 || length(ci) == 0){ errorCondition(recall=StatMedSampleMeansCI, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleMeanCI(", sd, ", ", delta, ", ", ci, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation (expected)")), sdEntry, sticky="w") tkgrid.configure(sdEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Confidence interval width")), deltaEntry, sticky="w") tkgrid.configure(deltaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Confidence level")), ciEntry, sticky="w") tkgrid.configure(ciEntry, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSamplePhaseII <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size from control and desired response rates")) p1 <- tclVar("") p1Entry <- ttkentry(top, width="20", textvariable=p1) p2 <- tclVar("") p2Entry <- ttkentry(top, width="20", textvariable=p2) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) power <- tclVar("0.80") powerEntry <- ttkentry(top, width="20", textvariable=power) checkBoxes(frame="twostage", boxes=c("twostage"),initialValues=c(1),labels=gettextRcmdr(c("Calculate two-stage model"))) # radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size from control and desired response rates"), "#####", sep="")) p1 <- tclvalue(p1) p2 <- tclvalue(p2) alpha <- tclvalue(alpha) power <- tclvalue(power) twostage <- tclvalue(twostageVariable) closeDialog() if (length(p1) == 0 || length(p2) == 0){ errorCondition(recall=StatMedSamplePhaseII, message=gettextRcmdr("You must select a variable.")) return() } if (as.numeric(p1) >= as.numeric(p2)){ errorCondition(recall=StatMedSamplePhaseII, message=gettextRcmdr("Desirable response rate must be higher than unacceptable response rate.")) return() } if (length(alpha) == 0 || length(power) == 0 ){ errorCondition(recall=StatMedSamplePhaseII, message=gettextRcmdr("You must select a variable.")) return() } doItAndPrint("library(clinfun, quietly=TRUE)") command <- paste("ph2single(", p1, ", ", p2, ", ", alpha, ", (1-", power, "), nsoln=1)", sep="") doItAndPrint(command) if (twostage==1){ command <- paste("ph2simon(", p1, ", ", p2, ", ", alpha, ", (1-", power, "), nmax=200)", sep="") #Two-stage doItAndPrint(command) } logger(gettextRcmdr("# r: if the number of response is equal to or fewer than r, the treatment is rejected.")) if (twostage==1){ logger(gettextRcmdr("# r1, n1: numbers in the first stage, r, n: total numbers in the study.")) } tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Unacceptable response rate")), p1Entry, sticky="w") tkgrid.configure(p1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Desirable response rate")), p2Entry, sticky="w") tkgrid.configure(p2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Power (1 - beta error)")), powerEntry, sticky="w") tkgrid.configure(powerEntry, sticky="w") tkgrid(twostage, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleMeans <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size for comparison between two means")) difference <- tclVar("") differenceEntry <- ttkentry(top, width="20", textvariable=difference) stddevi <- tclVar("") stddeviEntry <- ttkentry(top, width="20", textvariable=stddevi) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) power <- tclVar("0.80") powerEntry <- ttkentry(top, width="20", textvariable=power) ratio <- tclVar("1") ratioEntry <- ttkentry(top, width="20", textvariable=ratio) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size for comparison between two means"), "#####", sep="")) difference <- tclvalue(difference) stddevi <- tclvalue(stddevi) alpha <- tclvalue(alpha) power <- tclvalue(power) ratio <- tclvalue(ratio) method <- tclvalue(methodVariable) closeDialog() if (length(difference) == 0 || length(stddevi) == 0){ errorCondition(recall=StatMedSampleMeans, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(power) == 0 || length(ratio) == 0){ errorCondition(recall=StatMedSampleMeans, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleMean(", difference, ", ", stddevi, ", ", alpha, ", ", power, ", ", method, ", ", ratio, ")", sep="") result <- doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Difference in means")), differenceEntry, sticky="w") tkgrid.configure(differenceEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation in each group")), stddeviEntry, sticky="w") tkgrid.configure(stddeviEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Power (1 - beta error)")), powerEntry, sticky="w") tkgrid.configure(powerEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size ratio (1:X)")), ratioEntry, sticky="w") tkgrid.configure(ratioEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedPowerMeans <- function(){ initializeDialog(title=gettextRcmdr("Calculate power for comparison between two means")) difference <- tclVar("") differenceEntry <- ttkentry(top, width="20", textvariable=difference) stddevi <- tclVar("") stddeviEntry <- ttkentry(top, width="20", textvariable=stddevi) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) sample1 <- tclVar("") sample1Entry <- ttkentry(top, width="20", textvariable=sample1) sample2 <- tclVar("") sample2Entry <- ttkentry(top, width="20", textvariable=sample2) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate power for comparison between two means"), "#####", sep="")) difference <- tclvalue(difference) stddevi <- tclvalue(stddevi) alpha <- tclvalue(alpha) sample1 <- as.numeric(tclvalue(sample1)) sample2 <- as.numeric(tclvalue(sample2)) if (sample1 >= sample2){ sample <- sample2 ratio <- sample1/sample2 } else { sample <- sample1 ratio <- sample2/sample1 } method <- tclvalue(methodVariable) closeDialog() if (length(difference) == 0 || length(stddevi) == 0){ errorCondition(recall=StatMedPowerMeans, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(sample) == 0 || length(ratio) == 0){ errorCondition(recall=StatMedPowerMeans, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("PowerMean(", difference, ", ", stddevi, ", ", alpha, ", ", sample, ", ", method, ", ", ratio, ")", sep="") result <- doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Difference in means")), differenceEntry, sticky="w") tkgrid.configure(differenceEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation in each group")), stddeviEntry, sticky="w") tkgrid.configure(stddeviEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size of group 1")), sample1Entry, sticky="w") tkgrid.configure(sample1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size of group 2")), sample2Entry, sticky="w") tkgrid.configure(sample2Entry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleMeansNonInf <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size for non-inferiority trial of two means")) difference <- tclVar("") differenceEntry <- ttkentry(top, width="20", textvariable=difference) delta <- tclVar("") deltaEntry <- ttkentry(top, width="20", textvariable=delta) stddevi <- tclVar("") stddeviEntry <- ttkentry(top, width="20", textvariable=stddevi) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) power <- tclVar("0.80") powerEntry <- ttkentry(top, width="20", textvariable=power) # ratio <- tclVar("1") # ratioEntry <- ttkentry(top, width="20", textvariable=ratio) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), initialValue=1, labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size for non-inferiority trial of two means"), "#####", sep="")) difference <- tclvalue(difference) delta <- tclvalue(delta) stddevi <- tclvalue(stddevi) alpha <- tclvalue(alpha) power <- tclvalue(power) # ratio <- tclvalue(ratio) method <- tclvalue(methodVariable) closeDialog() if (length(difference) == 0 || length(delta) == 0 || length(stddevi) == 0){ errorCondition(recall=StatMedSampleMeans, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(power) == 0){ errorCondition(recall=StatMedSampleMeans, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleMeanNonInf(", difference, ", ", delta, ", ", stddevi, ", ", alpha, ", ", power, ", ", method, ")", sep="") result <- doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Difference in means (test - control)")), differenceEntry, sticky="w") tkgrid.configure(differenceEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Meaningful difference in mean")), deltaEntry, sticky="w") tkgrid.configure(deltaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation in each group")), stddeviEntry, sticky="w") tkgrid.configure(stddeviEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Power (1 - beta error)")), powerEntry, sticky="w") tkgrid.configure(powerEntry, sticky="w") # tkgrid(tklabel(top, text=gettextRcmdr("Sample size ratio (1:X)")), ratioEntry, sticky="w") # tkgrid.configure(ratioEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleMeansPaired <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size for comparison between two paired means")) difference <- tclVar("") differenceEntry <- ttkentry(top, width="20", textvariable=difference) stddevi <- tclVar("") stddeviEntry <- ttkentry(top, width="20", textvariable=stddevi) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) power <- tclVar("0.80") powerEntry <- ttkentry(top, width="20", textvariable=power) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size for comparison between two paired means"), "#####", sep="")) difference <- tclvalue(difference) stddevi <- tclvalue(stddevi) alpha <- tclvalue(alpha) power <- tclvalue(power) method <- tclvalue(methodVariable) closeDialog() if (length(difference) == 0 || length(stddevi) == 0){ errorCondition(recall=StatMedSampleMeansPaired, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(power) == 0){ errorCondition(recall=StatMedSampleMeansPaired, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleMeanPaired(", difference, ", ", stddevi, ", ", alpha, ", ", power, ", ", method, ")", sep="") result <- doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Difference in means")), differenceEntry, sticky="w") tkgrid.configure(differenceEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation in each group")), stddeviEntry, sticky="w") tkgrid.configure(stddeviEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Power (1 - beta error)")), powerEntry, sticky="w") tkgrid.configure(powerEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedPowerMeansPaired <- function(){ initializeDialog(title=gettextRcmdr("Calculate power for comparison between two paired means")) difference <- tclVar("") differenceEntry <- ttkentry(top, width="20", textvariable=difference) stddevi <- tclVar("") stddeviEntry <- ttkentry(top, width="20", textvariable=stddevi) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) sample <- tclVar("") sampleEntry <- ttkentry(top, width="20", textvariable=sample) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate power for comparison between two paired means"), "#####", sep="")) difference <- tclvalue(difference) stddevi <- tclvalue(stddevi) alpha <- tclvalue(alpha) sample <- as.numeric(tclvalue(sample)) method <- tclvalue(methodVariable) closeDialog() if (length(difference) == 0 || length(stddevi) == 0){ errorCondition(recall=StatMedPowerMeansPaired, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(sample) == 0){ errorCondition(recall=StatMedPowerMeansPaired, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("PowerMeanPaired(", difference, ", ", stddevi, ", ", alpha, ", ", sample, ", ", method, ")", sep="") result <- doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Difference in means")), differenceEntry, sticky="w") tkgrid.configure(differenceEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Standard deviation in each group")), stddeviEntry, sticky="w") tkgrid.configure(stddeviEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size")), sampleEntry, sticky="w") tkgrid.configure(sampleEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleProportions <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size for comparison between two proportions"))#Chi-square test with continuity correnction group1 <- tclVar("") group1Entry <- ttkentry(top, width="20", textvariable=group1) group2 <- tclVar("") group2Entry <- ttkentry(top, width="20", textvariable=group2) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) power <- tclVar("0.80") powerEntry <- ttkentry(top, width="20", textvariable=power) ratio <- tclVar("1") ratioEntry <- ttkentry(top, width="20", textvariable=ratio) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) radioButtons(name="continuity", buttons=c("Yes", "No"), values=c(1, 0), labels=gettextRcmdr(c("Yes (or Fisher's exact test)", "No correction")),title=gettextRcmdr("Continuity correction of chi-square test")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size for comparison between two proportions"), "#####", sep="")) group1 <- tclvalue(group1) group2 <- tclvalue(group2) alpha <- tclvalue(alpha) power <- tclvalue(power) ratio <- tclvalue(ratio) method <- tclvalue(methodVariable) continuity <- tclvalue(continuityVariable) closeDialog() if (length(group1) == 0 || length(group2) == 0){ errorCondition(recall=StatMedSampleProportions, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(power) == 0 || length(ratio) == 0){ errorCondition(recall=StatMedSampleProportions, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleProportion(", group1, ", ", group2, ", ", alpha, ", ", power, ", ", method, ", ", ratio, ", ", continuity, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Proportion in group 1")), group1Entry, sticky="w") tkgrid.configure(group1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Proportion in group 2")), group2Entry, sticky="w") tkgrid.configure(group2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Power (1 - beta error)")), powerEntry, sticky="w") tkgrid.configure(powerEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size ratio (1:X)")), ratioEntry, sticky="w") tkgrid.configure(ratioEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(continuityFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedPowerProportions <- function(){ initializeDialog(title=gettextRcmdr("Calculate power for comparison between two proportions")) group1 <- tclVar("") group1Entry <- ttkentry(top, width="20", textvariable=group1) group2 <- tclVar("") group2Entry <- ttkentry(top, width="20", textvariable=group2) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) sample1 <- tclVar("") sample1Entry <- ttkentry(top, width="20", textvariable=sample1) sample2 <- tclVar("") sample2Entry <- ttkentry(top, width="20", textvariable=sample2) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) radioButtons(name="continuity", buttons=c("Yes", "No"), values=c(1, 0), labels=gettextRcmdr(c("Yes (or Fisher's exact test)", "No correction")),title=gettextRcmdr("Continuity correction of chi-square test")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate power for comparison between two proportions"), "#####", sep="")) group1 <- tclvalue(group1) group2 <- tclvalue(group2) alpha <- tclvalue(alpha) sample1 <- as.numeric(tclvalue(sample1)) sample2 <- as.numeric(tclvalue(sample2)) if (sample1 >= sample2){ sample <- sample2 ratio <- sample1/sample2 } else { sample <- sample1 ratio <- sample2/sample1 } method <- tclvalue(methodVariable) continuity <- tclvalue(continuityVariable) closeDialog() if (length(group1) == 0 || length(group2) == 0){ errorCondition(recall=StatMedPowerProportions, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(sample1) == 0 || length(sample2) == 0){ errorCondition(recall=StatMedPowerProportions, message=gettextRcmdr("You must select a variable.")) return() } # library(statmod) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("PowerProportion(", group1, ", ", group2, ", ", alpha, ", ", sample, ", ", method, ", ", ratio, ", ", continuity, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Proportion in group 1")), group1Entry, sticky="w") tkgrid.configure(group1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Proportion in group 2")), group2Entry, sticky="w") tkgrid.configure(group2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size of group 1")), sample1Entry, sticky="w") tkgrid.configure(sample1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size of group 2")), sample2Entry, sticky="w") tkgrid.configure(sample2Entry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(continuityFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleProportionsNonInf <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size for non-inferiority trial of two proportions")) group1 <- tclVar("") group1Entry <- ttkentry(top, width="20", textvariable=group1) group2 <- tclVar("") group2Entry <- ttkentry(top, width="20", textvariable=group2) delta <- tclVar("") deltaEntry <- ttkentry(top, width="20", textvariable=delta) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) power <- tclVar("0.80") powerEntry <- ttkentry(top, width="20", textvariable=power) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), initialValue=1, labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size for non-inferiority trial of two proportions"), "#####", sep="")) group1 <- tclvalue(group1) group2 <- tclvalue(group2) delta <- tclvalue(delta) alpha <- tclvalue(alpha) power <- tclvalue(power) method <- tclvalue(methodVariable) closeDialog() if (length(group1) == 0 || length(group2) == 0 || length(delta) == 0){ errorCondition(recall=StatMedSampleProportionsNonInf, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(power) == 0){ errorCondition(recall=StatMedSampleProportionsNonInf, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleProportionNonInf(", group1, ", ", group2, ", ", delta, ", ", alpha, ", ", power, ", ", method, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Proportion in control group")), group1Entry, sticky="w") tkgrid.configure(group1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Proportion in test group")), group2Entry, sticky="w") tkgrid.configure(group2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Meaningful difference in proportion")), deltaEntry, sticky="w") tkgrid.configure(deltaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Power (1 - beta error)")), powerEntry, sticky="w") tkgrid.configure(powerEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleSelectionDesign <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size for selection design in randomized phase II trials")) Smallest <- tclVar("") SmallestEntry <- ttkentry(top, width="20", textvariable=Smallest) Diff <- tclVar("0.15") DiffEntry <- ttkentry(top, width="20", textvariable=Diff) Arms <- tclVar("") ArmsEntry <- ttkentry(top, width="20", textvariable=Arms) Desired <- tclVar("0.90") DesiredEntry <- ttkentry(top, width="20", textvariable=Desired) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size for selection design in randomized phase II trials"), "#####", sep="")) Smallest <- tclvalue(Smallest) Diff <- tclvalue(Diff) Arms <- tclvalue(Arms) Desired <- tclvalue(Desired) closeDialog() if (length(Smallest) == 0 || length(Diff) == 0 || length(Arms) == 0 || length(Desired) == 0){ errorCondition(recall=StatMedSampleSelectionDesign, message=gettextRcmdr("You must select a variable.")) return() } command <- paste("SampleSelectionDesign(", Smallest, ", ", Diff, ", ", Arms, ", ", Desired, ")", sep="") doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Smallest response rate")), SmallestEntry, sticky="w") tkgrid.configure(SmallestEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Difference in response rate")), DiffEntry, sticky="w") tkgrid.configure(DiffEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Number of treatment arms")), ArmsEntry, sticky="w") tkgrid.configure(ArmsEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Desired Probability")), DesiredEntry, sticky="w") tkgrid.configure(DesiredEntry, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleHazard <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size for comparison between two survival curves")) enrol <- tclVar("") enrolEntry <- ttkentry(top, width="20", textvariable=enrol) studyperiod <- tclVar("") studyperiodEntry <- ttkentry(top, width="20", textvariable=studyperiod) followup <- tclVar("") followupEntry <- ttkentry(top, width="20", textvariable=followup) group1 <- tclVar("") group1Entry <- ttkentry(top, width="20", textvariable=group1) group2 <- tclVar("") group2Entry <- ttkentry(top, width="20", textvariable=group2) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) power <- tclVar("0.80") powerEntry <- ttkentry(top, width="20", textvariable=power) ratio <- tclVar("1") ratioEntry <- ttkentry(top, width="20", textvariable=ratio) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size for comparison between two survival curves"), "#####", sep="")) enrol <- tclvalue(enrol) studyperiod <- tclvalue(studyperiod) followup <- tclvalue(followup) group1 <- tclvalue(group1) group2 <- tclvalue(group2) alpha <- tclvalue(alpha) power <- tclvalue(power) ratio <- tclvalue(ratio) method <- tclvalue(methodVariable) closeDialog() if (length(enrol) == 0 || length(studyperiod) == 0 || length(followup) == 0){ errorCondition(recall=StatMedSampleHazard, message=gettextRcmdr("You must select a variable.")) return() } if (length(group1) == 0 || length(group2) == 0){ errorCondition(recall=StatMedSampleHazard, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(power) == 0 || length(ratio) == 0){ errorCondition(recall=StatMedSampleHazard, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleHazard(", enrol, ", ", studyperiod, ", ", followup, ", ", group1, ", ", group2, ", ", alpha, ", ", power, ", ", method, ", ", ratio, ")", sep="") result <- doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Accrual duration")), enrolEntry, sticky="w") tkgrid.configure(enrolEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Total (accrual + follow-up) duration")), studyperiodEntry, sticky="w") tkgrid.configure(studyperiodEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Survival ratio at n year in each group")), followupEntry, sticky="w") tkgrid.configure(followupEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Survival rate in group 1")), group1Entry, sticky="w") tkgrid.configure(group1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Survival rate in group 2")), group2Entry, sticky="w") tkgrid.configure(group2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Power (1 - beta error)")), powerEntry, sticky="w") tkgrid.configure(powerEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size ratio (1:X)")), ratioEntry, sticky="w") tkgrid.configure(ratioEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedPowerHazard <- function(){ initializeDialog(title=gettextRcmdr("Calculate power for comparison between two survival curves")) enrol <- tclVar("") enrolEntry <- ttkentry(top, width="20", textvariable=enrol) studyperiod <- tclVar("") studyperiodEntry <- ttkentry(top, width="20", textvariable=studyperiod) followup <- tclVar("") followupEntry <- ttkentry(top, width="20", textvariable=followup) group1 <- tclVar("") group1Entry <- ttkentry(top, width="20", textvariable=group1) group2 <- tclVar("") group2Entry <- ttkentry(top, width="20", textvariable=group2) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) sample1 <- tclVar("") sample1Entry <- ttkentry(top, width="20", textvariable=sample1) sample2 <- tclVar("") sample2Entry <- ttkentry(top, width="20", textvariable=sample2) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate power for comparison between two survival curves"), "#####", sep="")) enrol <- tclvalue(enrol) studyperiod <- tclvalue(studyperiod) followup <- tclvalue(followup) group1 <- tclvalue(group1) group2 <- tclvalue(group2) alpha <- tclvalue(alpha) sample1 <- as.numeric(tclvalue(sample1)) sample2 <- as.numeric(tclvalue(sample2)) if (sample1 >= sample2){ sample <- sample2 ratio <- sample1/sample2 } else { sample <- sample1 ratio <- sample2/sample1 } method <- tclvalue(methodVariable) closeDialog() if (length(enrol) == 0 || length(studyperiod) == 0 || length(followup) == 0){ errorCondition(recall=StatMedPowerHazard, message=gettextRcmdr("You must select a variable.")) return() } if (length(group1) == 0 || length(group2) == 0){ errorCondition(recall=StatMedPowerHazard, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(sample1) == 0 || length(sample2) == 0){ errorCondition(recall=StatMedPowerHazard, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("PowerHazard(", enrol, ", ", studyperiod, ", ", followup, ", ", group1, ", ", group2, ", ", alpha, ", ", sample, ", ", method, ", ", ratio, ")", sep="") result <- doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Accrual duration")), enrolEntry, sticky="w") tkgrid.configure(enrolEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Total (accrual + follow-up) duration")), studyperiodEntry, sticky="w") tkgrid.configure(studyperiodEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Survival ratio at n year in each group")), followupEntry, sticky="w") tkgrid.configure(followupEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Survival rate in group 1")), group1Entry, sticky="w") tkgrid.configure(group1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Survival rate in group 2")), group2Entry, sticky="w") tkgrid.configure(group2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size of group 1")), sample1Entry, sticky="w") tkgrid.configure(sample1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size of group 2")), sample2Entry, sticky="w") tkgrid.configure(sample2Entry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedSampleHazardNonInf <- function(){ initializeDialog(title=gettextRcmdr("Calculate sample size for non-inferiority trial of two survival curves")) enrol <- tclVar("") enrolEntry <- ttkentry(top, width="20", textvariable=enrol) studyperiod <- tclVar("") studyperiodEntry <- ttkentry(top, width="20", textvariable=studyperiod) followup <- tclVar("") followupEntry <- ttkentry(top, width="20", textvariable=followup) group1 <- tclVar("") group1Entry <- ttkentry(top, width="20", textvariable=group1) group2 <- tclVar("") group2Entry <- ttkentry(top, width="20", textvariable=group2) lowerlimit <- tclVar("") lowerlimitEntry <- ttkentry(top, width="20", textvariable=lowerlimit) alpha <- tclVar("0.05") alphaEntry <- ttkentry(top, width="20", textvariable=alpha) power <- tclVar("0.80") powerEntry <- ttkentry(top, width="20", textvariable=power) ratio <- tclVar("1") ratioEntry <- ttkentry(top, width="20", textvariable=ratio) radioButtons(name="method", buttons=c("Two.sided", "One.sided"), values=c(2, 1), initialValue=1, labels=gettextRcmdr(c("Two-sided", "One-sided")),title=gettextRcmdr("Method")) onOK <- function(){ logger(paste("#####", gettextRcmdr("Calculate sample size for non-inferiority trial of two survival curves"), "#####", sep="")) enrol <- tclvalue(enrol) studyperiod <- tclvalue(studyperiod) followup <- tclvalue(followup) group1 <- tclvalue(group1) group2 <- tclvalue(group2) lowerlimit <- tclvalue(lowerlimit) alpha <- tclvalue(alpha) power <- tclvalue(power) ratio <- tclvalue(ratio) method <- tclvalue(methodVariable) closeDialog() if (length(enrol) == 0 || length(studyperiod) == 0 || length(followup) == 0){ errorCondition(recall=StatMedSampleHazard, message=gettextRcmdr("You must select a variable.")) return() } if (length(group1) == 0 || length(group2) == 0 || length(lowerlimit) == 0){ errorCondition(recall=StatMedSampleHazard, message=gettextRcmdr("You must select a variable.")) return() } if (length(alpha) == 0 || length(power) == 0 || length(ratio) == 0){ errorCondition(recall=StatMedSampleHazard, message=gettextRcmdr("You must select a variable.")) return() } if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} command <- paste("SampleHazardNonInf(", enrol, ", ", studyperiod, ", ", followup, ", ", group1, ", ", group2, ", ", lowerlimit, ", ", alpha, ", ", power, ", ", method, ", ", ratio, ")", sep="") result <- doItAndPrint(command) tkfocus(CommanderWindow()) } OKCancelHelp() tkgrid(tklabel(top, text=gettextRcmdr("Accrual duration")), enrolEntry, sticky="w") tkgrid.configure(enrolEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Total (accrual + follow-up) duration")), studyperiodEntry, sticky="w") tkgrid.configure(studyperiodEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Survival ratio at n year in each group")), followupEntry, sticky="w") tkgrid.configure(followupEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Survival rate in control group")), group1Entry, sticky="w") tkgrid.configure(group1Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Survival rate in test group")), group2Entry, sticky="w") tkgrid.configure(group2Entry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Non-inferiority lower limit")), lowerlimitEntry, sticky="w") tkgrid.configure(lowerlimitEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Alpha error")), alphaEntry, sticky="w") tkgrid.configure(alphaEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Power (1 - beta error)")), powerEntry, sticky="w") tkgrid.configure(powerEntry, sticky="w") tkgrid(tklabel(top, text=gettextRcmdr("Sample size ratio (1:X)")), ratioEntry, sticky="w") tkgrid.configure(ratioEntry, sticky="w") tkgrid(methodFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=4, columns=1) } StatMedMeta <- function(){ defaults <- list(studyname=NULL, testpositive=NULL, testnumber=NULL, controlpositive=NULL, controlnumber=NULL, group=NULL, reg=NULL, endpoint="OR", dsl=1, detail=1, funnel=0, subset = "") dialog.values <- getDialog("StatMedMeta", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Metaanalysis and metaregression for proportions")) studynameBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variable to identify studies (pick 0 or 1)"), initialSelection=varPosn(dialog.values$studyname, "all")) variablesFrame <- tkframe(top) testpositiveBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Number of events in test group"), initialSelection=varPosn(dialog.values$testpositive, "all")) testnumberBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Number of samples in test group"), initialSelection=varPosn(dialog.values$testnumber, "all")) variables2Frame <- tkframe(top) controlpositiveBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Number of events in control group"), initialSelection=varPosn(dialog.values$controlpositive, "all")) controlnumberBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Number of samples in control group"), initialSelection=varPosn(dialog.values$controlnumber, "all")) variables3Frame <- tkframe(top) groupBox <- variableListBox(variables3Frame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), initialSelection=varPosn(dialog.values$group, "all")) regBox <- variableListBox(variables3Frame, Variables(), selectmode="multiple", title=gettextRcmdr("Variables for meta-regression"), initialSelection=varPosn(dialog.values$reg, "all")) radioButtons(name="endpoint", buttons=c("OR", "RR", "RD"), initialValue=dialog.values$endpoint, values=c("OR", "RR", "RD"), labels=gettextRcmdr(c("Odds ratio", "Relative risk", "Risk difference")),title=gettextRcmdr("Summary measure")) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("dsl", "detail", "funnel"), initialValues=c(dialog.values$dsl, dialog.values$detail, dialog.values$funnel),labels=gettextRcmdr(c("Conduct random effects meta-analysis", "Show detailed data in forest plot", "Evaluate publication bias with funnel plot"))) # checkBoxes(frame="dsl", boxes=c("dsl"),initialValues=c(1),labels=gettextRcmdr(c("Conduct random effects meta-analysis"))) # checkBoxes(frame="detail", boxes=c("detail"),initialValues=c(1),labels=gettextRcmdr(c("Show detailed data in forest plot"))) # checkBoxes(frame="funnel", boxes=c("funnel"),initialValues=c(0),labels=gettextRcmdr(c("Evaluate publication bias with funnel plot"))) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Metaanalysis and metaregression for proportions"), "#####", sep="")) studyname <- getSelection(studynameBox) testpositive <- getSelection(testpositiveBox) testnumber <- getSelection(testnumberBox) controlpositive <- getSelection(controlpositiveBox) controlnumber <- getSelection(controlnumberBox) group <- getSelection(groupBox) reg <- getSelection(regBox) dataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset <- "" } endpoint <- tclvalue(endpointVariable) dsl <- tclvalue(dslVariable) detail <- tclvalue(detailVariable) funnel <- tclvalue(funnelVariable) putDialog("StatMedMeta", list(studyname=studyname, testpositive=testpositive, testnumber=testnumber, controlpositive=controlpositive, controlnumber=controlnumber, group=group, reg=reg, endpoint=endpoint, dsl=dsl, detail=detail, funnel=funnel, subset = tclvalue(subsetVariable))) closeDialog() if (length(testpositive) == 0 || length(testnumber) == 0 || length(controlpositive) == 0 || length(controlnumber) == 0) { errorCondition(recall=StatMedMeta, message=gettextRcmdr("Pick all required variables")) return() } if (length(studyname) == 0 ){ studyname <- NULL } if (length(group) == 0 ){ group1 <- NULL group2 <- NULL } else { group1 <- paste(", byvar=", group, ', bylab="', group, '"') group2 <- paste(', bylab="', group, '"') } if (subset==""){ doItAndPrint(paste("TempDF <- ", dataSet, "[complete.cases(", dataSet, "$", testpositive, ", ", dataSet, "$", testnumber, ", ", dataSet, "$", controlpositive, ", ", dataSet, "$", controlnumber, "),]", sep="")) }else{ doItAndPrint(paste("TempDF <- subset(", dataSet, ", subset=", subset, ")[complete.cases(subset(", dataSet, ", subset=", subset, ")$", testpositive, ", subset(", dataSet, ", subset=", subset, ")$", testnumber, ", subset(", dataSet, ", subset=", subset, ")$", controlpositive, ", subset(", dataSet, ", subset=", subset, ")$", controlnumber, "),]", sep="")) } # library(meta, quietly=TRUE) Library("meta") doItAndPrint("res <- NULL") if (dsl==0) { command <- paste("res <- metabin(", testpositive, ", ", testnumber, ", ", controlpositive, ", ", controlnumber, ', data=TempDF, sm="', endpoint, '", studlab=', studyname, group1, ", comb.fixed=TRUE, comb.random=FALSE)", sep="") } else { command <- paste("res <- metabin(", testpositive, ", ", testnumber, ", ", controlpositive, ", ", controlnumber, ', data=TempDF, sm="', endpoint, '", studlab=', studyname, group1, ", comb.fixed=TRUE, comb.random=TRUE)", sep="") } doItAndPrint(command) doItAndPrint("res") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (detail == 0){ doItAndPrint("plot(res)") } else{ doItAndPrint(paste("forest.meta(res", group2, ")", sep="")) } if (funnel == 1) { if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("funnel(res)") doItAndPrint("metabias(res)") } if (length(reg) > 0) { doItAndPrint("Var <- (res$seTE)^2") doItAndPrint("library(metatest, quietly=TRUE)") for (i in 1:length(reg)){ doItAndPrint("y <- exp(res$TE)") doItAndPrint(paste("(metareg <- metatest(res$TE~TempDF$", reg[i], ", Var))", sep="")) doItAndPrint(paste("x <- TempDF$", reg[i], sep="")) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("y.L <- exp(res$TE-qnorm(0.975)*res$seTE)") doItAndPrint("y.H <- exp(res$TE+qnorm(0.975)*res$seTE)") doItAndPrint("max.weight <- sqrt(max(res$w.fixed))") doItAndPrint(paste('plot(y ~ x, ylab="Effect size", xlab="', reg[i], '", log="y", pch=15, cex=sqrt(res$w.fixed)*2.5/max.weight, ylim=c(min(y.L), max(y.H)))', sep="")) doItAndPrint("if(is.numeric(x)) arrows(x, y.L, x, y.H, code=3, angle=90, length=0.1)") doItAndPrint("metareg.table <- signif(cbind(metareg$coefficients, metareg$se, metareg$coef-qnorm(0.975)*metareg$se, metareg$coef+qnorm(0.975)*metareg$se, metareg$pZtest), digits=3)") doItAndPrint(paste('rownames(metareg.table) <- c("(Intercept)", "', reg[i], '")', sep="")) doItAndPrint('colnames(metareg.table) <- c("Coef", "SE", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("metareg.table<- data.frame(metareg.table)") doItAndPrint("metareg.table") # doItAndPrint("remove(metareg.table)") } } # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="metabin", apply="StatMedMeta", reset="StatMedMeta") tkgrid(getFrame(studynameBox), sticky="nw") tkgrid(getFrame(testpositiveBox), labelRcmdr(variablesFrame, text=" "), getFrame(testnumberBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(controlpositiveBox), labelRcmdr(variables2Frame, text=" "), getFrame(controlnumberBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(labelRcmdr(variables3Frame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(groupBox), labelRcmdr(variables3Frame, text=" "), getFrame(regBox), sticky="nw") tkgrid(variables3Frame, sticky="nw") # tkgrid(endpointFrame, sticky="w") # tkgrid(optionsFrame, sticky="w") tkgrid(optionsFrame, endpointFrame, sticky="w") # tkgrid(dsl, sticky="w") # tkgrid(detail, sticky="w") # tkgrid(funnel, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedMetaHazard <- function(){ defaults <- list(input="CI", studyname=NULL, hazard=NULL, ci=NULL, group=NULL, reg=NULL, dsl=1, detail=1, funnel=0, subset = "") dialog.values <- getDialog("StatMedMetaHazard", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Metaanalysis and metaregression for hazard ratios")) radioButtons(name="input", buttons=c("CI", "SE"), initialValue=dialog.values$input, values=c("CI", "SE"), labels=gettextRcmdr(c("Combine hazard ratio and 95% confidence interval", "Combine log hazard ratio and standard error")),title=gettextRcmdr("Choose data to combine")) studynameBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variable to identify studies (pick 0 or 1)"), initialSelection=varPosn(dialog.values$studyname, "all")) variablesFrame <- tkframe(top) hazardBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Hazard ratio or log hazard ratio (pick one)"), initialSelection=varPosn(dialog.values$hazard, "all")) ciBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Upper limit of 95% confidence interval or standard error (pick one)"), initialSelection=varPosn(dialog.values$ci, "all")) variables2Frame <- tkframe(top) groupBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), initialSelection=varPosn(dialog.values$group, "all")) regBox <- variableListBox(variables2Frame, Variables(), selectmode="multiple", title=gettextRcmdr("Variables for meta-regression"), initialSelection=varPosn(dialog.values$reg, "all")) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("dsl", "detail", "funnel"), initialValues=c(dialog.values$dsl, dialog.values$detail, dialog.values$funnel),labels=gettextRcmdr(c("Conduct random effects meta-analysis", "Show detailed data in forest plot", "Evaluate publication bias with funnel plot"))) # checkBoxes(frame="dsl", boxes=c("dsl"),initialValues=c(1),labels=gettextRcmdr(c("Conduct random effects meta-analysis"))) # checkBoxes(frame="detail", boxes=c("detail"),initialValues=c(1),labels=gettextRcmdr(c("Show detailed data in forest plot"))) # checkBoxes(frame="funnel", boxes=c("funnel"),initialValues=c(0),labels=gettextRcmdr(c("Evaluate publication bias with funnel plot."))) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Metaanalysis and metaregression for hazard ratios"), "#####", sep="")) studyname <- getSelection(studynameBox) hazard <- getSelection(hazardBox) upperci <- getSelection(ciBox) group <- getSelection(groupBox) reg <- getSelection(regBox) dataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")){ subset <- "" } input <- tclvalue(inputVariable) dsl <- tclvalue(dslVariable) detail <- tclvalue(detailVariable) funnel <- tclvalue(funnelVariable) putDialog("StatMedMetaHazard",list(input=input, studyname=studyname, hazard=hazard, ci=upperci, group=group, reg=reg, dsl=dsl, detail=detail, funnel=funnel, subset = tclvalue(subsetVariable))) closeDialog() if (length(hazard) == 0 || length(upperci) == 0) { errorCondition(recall=StatMedMetaHazard, message=gettextRcmdr("Pick all required variables")) return() } if (length(studyname) == 0 ){ studyname <- NULL } if (length(group) == 0 ){ group1 <- NULL group2 <- NULL } else { group1 <- paste(", byvar=", group, ', bylab="', group, '"') group2 <- paste(', bylab="', group, '"') } if (subset==""){ doItAndPrint(paste("TempDF <- ", dataSet, "[complete.cases(", dataSet, "$", hazard, ", ", dataSet, "$", upperci, "),]", sep="")) } else { doItAndPrint(paste("TempDF <- subset(", dataSet, ", subset=", subset, ")[complete.cases(subset(", dataSet, ", subset=", subset, ")$", hazard, ", subset(", dataSet, ", subset=", subset, ")$", upperci, "),]", sep="")) } # library(meta, quietly=TRUE) Library("meta") if (input == "CI"){ doItAndPrint(paste("logHR <- log(TempDF$", hazard, ")", sep="")) doItAndPrint(paste("logSE <- (log(TempDF$", upperci, ")-log(TempDF$", hazard, ")) / qnorm(0.975)", sep="")) } else { doItAndPrint(paste("logHR <- TempDF$", hazard, sep="")) doItAndPrint(paste("logSE <- TempDF$", upperci, sep="")) } doItAndPrint("res <- NULL") if (dsl==0) { command <- paste('res <- metagen(logHR, logSE, data=TempDF, sm="HR", studlab=', studyname, group1, ", comb.fixed=TRUE, comb.random=FALSE)", sep="") } else { command <- paste('res <- metagen(logHR, logSE, data=TempDF, sm="HR", studlab=', studyname, group1, ", comb.fixed=TRUE, comb.random=TRUE)", sep="") } doItAndPrint(command) doItAndPrint("res") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (detail == 0){ doItAndPrint("plot(res)") } else{ doItAndPrint(paste("forest.meta(res", group2, ")", sep="")) } if (funnel == 1) { if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("funnel(res)") doItAndPrint("metabias(res)") } if (length(reg) > 0) { doItAndPrint("Var <- (res$seTE)^2") doItAndPrint("library(metatest, quietly=TRUE)") for (i in 1:length(reg)){ doItAndPrint("y <- exp(res$TE)") doItAndPrint(paste("(metareg <- metatest(res$TE~TempDF$", reg[i], ", Var))", sep="")) doItAndPrint(paste("x <- TempDF$", reg[i], sep="")) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("y.L <- exp(res$TE-qnorm(0.975)*res$seTE)") doItAndPrint("y.H <- exp(res$TE+qnorm(0.975)*res$seTE)") doItAndPrint("max.weight <- sqrt(max(res$w.fixed))") doItAndPrint(paste('plot(y ~ x, ylab="Effect size", xlab="', reg[i], '", log="y", pch=15, cex=sqrt(res$w.fixed)*2.5/max.weight, ylim=c(min(y.L), max(y.H)))', sep="")) doItAndPrint("if(is.numeric(x)) arrows(x, y.L, x, y.H, code=3, angle=90, length=0.1)") doItAndPrint("metareg.table <- signif(cbind(metareg$coefficients, metareg$se, metareg$coef-qnorm(0.975)*metareg$se, metareg$coef+qnorm(0.975)*metareg$se, metareg$pZtest), digits=3)") doItAndPrint(paste('rownames(metareg.table) <- c("(Intercept)", "', reg[i], '")', sep="")) doItAndPrint('colnames(metareg.table) <- c("Coef", "SE", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("metareg.table<- data.frame(metareg.table)") doItAndPrint("metareg.table") # doItAndPrint("remove(metareg.table)") } } # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="metagen", apply="StatMedMetaHazard", reset="StatMedMetaHazard") tkgrid(inputFrame, sticky="w") tkgrid(getFrame(studynameBox), sticky="nw") tkgrid(getFrame(hazardBox), labelRcmdr(variablesFrame, text=" "), getFrame(ciBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(labelRcmdr(variables2Frame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(groupBox), labelRcmdr(variables2Frame, text=" "), getFrame(regBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(optionsFrame, sticky="nw") # tkgrid(dsl, sticky="w") # tkgrid(funnel, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedMetaCont <- function(){ defaults <- list(studyname=NULL, testmean=NULL, testnumber=NULL, testsd=NULL, controlmean=NULL, controlnumber=NULL, controlsd=NULL, group=NULL, reg=NULL, smd=0, dsl=1, detail=1, funnel=0, smd=0, subset = "") dialog.values <- getDialog("StatMedMetaCont", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Metaanalysis and metaregression for means")) studynameBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variable to identify studies (pick 0 or 1)"), initialSelection=varPosn(dialog.values$studyname, "all")) variablesFrame <- tkframe(top) testmeanBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Mean in test group"), initialSelection=varPosn(dialog.values$testmean, "all")) testnumberBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Number of samples in test group"), initialSelection=varPosn(dialog.values$testnumber, "all")) testsdBox <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Standard deviation in test group"), initialSelection=varPosn(dialog.values$testsd, "all")) variables2Frame <- tkframe(top) controlmeanBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Mean in control group"), initialSelection=varPosn(dialog.values$controlmean, "all")) controlnumberBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Number of samples in control group"), initialSelection=varPosn(dialog.values$controlnumber, "all")) controlsdBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Standard deviation in control group"), initialSelection=varPosn(dialog.values$controlsd, "all")) variables3Frame <- tkframe(top) groupBox <- variableListBox(variables3Frame, Variables(), title=gettextRcmdr("Grouping variable(pick 0 or 1)"), initialSelection=varPosn(dialog.values$group, "all")) regBox <- variableListBox(variables3Frame, Variables(), selectmode="multiple", title=gettextRcmdr("Variables for meta-regression"), initialSelection=varPosn(dialog.values$reg, "all")) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("smd", "dsl", "detail", "funnel"), initialValues=c(dialog.values$smd, dialog.values$dsl, dialog.values$detail, dialog.values$funnel),labels=gettextRcmdr(c("Pool standard mead difference", "Conduct random effects meta-analysis", "Show detailed data in forest plot", "Evaluate publication bias with funnel plot"))) # checkBoxes(frame="dsl", boxes=c("dsl"),initialValues=c(1),labels=gettextRcmdr(c("Conduct random effects meta-analysis"))) # checkBoxes(frame="detail", boxes=c("detail"),initialValues=c(1),labels=gettextRcmdr(c("Show detailed data in forest plot"))) # checkBoxes(frame="funnel", boxes=c("funnel"),initialValues=c(0),labels=gettextRcmdr(c("Evaluate publication bias with funnel plot"))) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Metaanalysis and metaregression for means"), "#####", sep="")) studyname <- getSelection(studynameBox) testmean <- getSelection(testmeanBox) testnumber <- getSelection(testnumberBox) testsd <- getSelection(testsdBox) controlmean <- getSelection(controlmeanBox) controlnumber <- getSelection(controlnumberBox) controlsd <- getSelection(controlsdBox) group <- getSelection(groupBox) reg <- getSelection(regBox) dataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset <- "" } if (length(studyname) == 0 ){ studyname <- NULL } if (length(group) == 0 ){ group1 <- NULL group2 <- NULL } else { group1 <- paste(", byvar=", group, ', bylab="', group, '"') group2 <- paste(', bylab="', group, '"') } smd <- tclvalue(smdVariable) dsl <- tclvalue(dslVariable) detail <- tclvalue(detailVariable) funnel <- tclvalue(funnelVariable) if (subset==""){ doItAndPrint(paste("TempDF <- ", dataSet, "[complete.cases(", dataSet, "$", testnumber, ", ", dataSet, "$", testmean, ", ", dataSet, "$", testsd, ", ", dataSet, "$", controlnumber, ", ", dataSet, "$", controlmean, ", ", dataSet, "$", controlsd, "),]", sep="")) }else{ doItAndPrint(paste("TempDF <- subset(", dataSet, ", subset=", subset, ")[complete.cases(subset(", dataSet, ", subset=", subset, ")$", testnumber, ", subset(", dataSet, ", subset=", subset, ")$", testmean, ", subset(", dataSet, ", subset=", subset, ")$", testsd, ", subset(", dataSet, ", subset=", subset, ")$", controlnumber, ", subset(", dataSet, ", subset=", subset, ")$", controlmean, ", subset(", dataSet, ", subset=", subset, ")$", controlsd, "),]", sep="")) } putDialog("StatMedMetaCont", list(studyname=studyname, testmean=testmean, testnumber=testnumber, testsd=testsd, controlmean=controlmean, controlnumber=controlnumber, controlsd=controlsd, group=group, reg=reg, dsl=dsl, detail=detail, funnel=funnel, smd=smd, subset = tclvalue(subsetVariable))) closeDialog() if (length(testmean) == 0 || length(testnumber) == 0 || length(testsd) == 0 || length(controlmean) == 0 || length(controlnumber) == 0 || length(controlsd) == 0) { errorCondition(recall=StatMedMetaCont, message=gettextRcmdr("Pick all required variables")) return() } # library(meta, quietly=TRUE) Library("meta") smd <- ifelse(smd==0, ', sm="MD"', ', sm="SMD"') doItAndPrint("res <- NULL") if (dsl==0) { command <- paste("res <- metacont(", testnumber, ", ", testmean, ", ", testsd, ", ", controlnumber, ", ", controlmean, ", ", controlsd, ", data=TempDF, studlab=", studyname, group1, ", comb.fixed=TRUE, comb.random=FALSE", smd, ")", sep="") } else { command <- paste("res <- metacont(", testnumber, ", ", testmean, ", ", testsd, ", ", controlnumber, ", ", controlmean, ", ", controlsd, ", data=TempDF, studlab=", studyname, group1, ", comb.fixed=TRUE, comb.random=TRUE", smd, ")", sep="") } doItAndPrint(command) doItAndPrint("res") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} if (detail == 0){ doItAndPrint("plot(res)") } else{ doItAndPrint(paste("forest.meta(res", group2, ")", sep="")) } if (funnel == 1) { if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("funnel(res)") doItAndPrint("metabias(res)") } if (length(reg) > 0) { doItAndPrint("Var <- (res$seTE)^2") doItAndPrint("library(metatest, quietly=TRUE)") for (i in 1:length(reg)){ doItAndPrint("y <- res$TE") doItAndPrint(paste("(metareg <- metatest(res$TE~TempDF$", reg[i], ", Var))", sep="")) doItAndPrint(paste("x <- TempDF$", reg[i], sep="")) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("y.L <- res$TE-qnorm(0.975)*res$seTE") doItAndPrint("y.H <- res$TE+qnorm(0.975)*res$seTE") doItAndPrint("max.weight <- sqrt(max(res$w.fixed))") doItAndPrint(paste('plot(y ~ x, ylab="Effect size", xlab="', reg[i], '", pch=15, cex=sqrt(res$w.fixed)*2.5/max.weight, ylim=c(min(y.L), max(y.H)))', sep="")) doItAndPrint("if(is.numeric(x)) arrows(x, y.L, x, y.H, code=3, angle=90, length=0.1)") doItAndPrint("metareg.table <- signif(cbind(metareg$coefficients, metareg$se, metareg$coef-qnorm(0.975)*metareg$se, metareg$coef+qnorm(0.975)*metareg$se, metareg$pZtest), digits=3)") doItAndPrint(paste('rownames(metareg.table) <- c("(Intercept)", "', reg[i], '")', sep="")) doItAndPrint('colnames(metareg.table) <- c("Coef", "SE", "Lower 95%CI", "Upper 95%CI", "p.value")') doItAndPrint("metareg.table<- data.frame(metareg.table)") doItAndPrint("metareg.table") # doItAndPrint("remove(metareg.table)") } } # doItAndPrint("remove(res)") tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="metacont", apply="StatMedMetaCont", reset="StatMedMetaCont") tkgrid(getFrame(studynameBox), sticky="nw") tkgrid(getFrame(testmeanBox), labelRcmdr(variablesFrame, text=" "), getFrame(testnumberBox), getFrame(testsdBox), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(controlmeanBox), labelRcmdr(variables2Frame, text=" "), getFrame(controlnumberBox), getFrame(controlsdBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") tkgrid(labelRcmdr(variables3Frame, text=gettextRcmdr("Click pressing Ctrl key to select multiple variables."), fg="blue"), sticky="w") tkgrid(getFrame(groupBox), labelRcmdr(variables3Frame, text=" "), getFrame(regBox), sticky="nw") tkgrid(variables3Frame, sticky="nw") tkgrid(optionsFrame, sticky="nw") # tkgrid(dsl, sticky="w") # tkgrid(funnel, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } StatMedNetworkMeta <- function(){ defaults <- list(studyname=NULL, treatment1=NULL, treatment2=NULL, effect=NULL, se=NULL, reference="", endpoint="HR", connection=0, netrank=1, heat=1, split=0, subset = "") dialog.values <- getDialog("StatMedNetworkMeta", defaults) currentFields$subset <- dialog.values$subset currentModel <- TRUE initializeDialog(title=gettextRcmdr("Network metaanalysis")) studynameBox <- variableListBox(top, Variables(), title=gettextRcmdr("Variable to identify studies"), initialSelection=varPosn(dialog.values$studyname, "all")) variablesFrame <- tkframe(top) treatment1Box <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Variable to identify treatment 1 name"), initialSelection=varPosn(dialog.values$treatment1, "all")) treatment2Box <- variableListBox(variablesFrame, Variables(), title=gettextRcmdr("Variable to identify treatment 2 name"), initialSelection=varPosn(dialog.values$treatment2, "all")) variables2Frame <- tkframe(top) effectBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Treatment effect"), initialSelection=varPosn(dialog.values$effect, "all")) seBox <- variableListBox(variables2Frame, Variables(), title=gettextRcmdr("Standard error of treatment effect"), initialSelection=varPosn(dialog.values$se, "all")) radioButtons(name="endpoint", buttons=c("OR", "RR", "RD", "HR", "MD", "SMD"), initialValue=dialog.values$endpoint, values=c("OR", "RR", "RD", "HR", "MD", "SMD"), labels=gettextRcmdr(c("Odds ratio", "Relative risk", "Risk difference", "Hazard ratio", "Mean difference", "Standardized mean difference")),title=gettextRcmdr("Summary measure")) refFrame <- tkframe(top) referenceFrame <- tkframe(refFrame) referenceVariable <- tclVar(dialog.values$reference) referenceField <- ttkentry(referenceFrame, width="20", textvariable=referenceVariable) optionsFrame <- tkframe(top) checkBoxes(frame="optionsFrame", boxes=c("connection", "netrank", "heat", "split"), initialValues=c(dialog.values$connection, dialog.values$netrank, dialog.values$heat, dialog.values$split),labels=gettextRcmdr(c("Show net connection", "Show Treatment rank", "Show net heat plot", "Compare direct and indirect evidence"))) StatMedSubsetBox(model=TRUE) onOK <- function(){ logger(paste("#####", gettextRcmdr("Network metaanalysis"), "#####", sep="")) studyname <- getSelection(studynameBox) treatment1 <- getSelection(treatment1Box) treatment2 <- getSelection(treatment2Box) effect <- getSelection(effectBox) se <- getSelection(seBox) dataSet <- ActiveDataSet() subset <- tclvalue(subsetVariable) if (trim.blanks(subset) == gettextRcmdr("<all valid cases>")) { subset <- "" } reference <- tclvalue(referenceVariable) endpoint <- tclvalue(endpointVariable) connection <- tclvalue(connectionVariable) netrank <- tclvalue(netrankVariable) heat <- tclvalue(heatVariable) split <- tclvalue(splitVariable) putDialog("StatMedNetworkMeta", list(studyname=studyname, treatment1=treatment1, treatment2=treatment2, effect=effect, se=se, reference=reference, endpoint=endpoint, connection=connection, netrank=netrank, heat=heat, split=split, subset = tclvalue(subsetVariable))) closeDialog() if (length(studyname) == 0 || length(treatment1) == 0 || length(treatment2) == 0 || length(effect) == 0 || length(se) == 0) { errorCondition(recall=StatMedNetworkMeta, message=gettextRcmdr("Pick all required variables")) return() } if (subset==""){ doItAndPrint(paste("TempDF <- ", dataSet, "[complete.cases(", dataSet, "$", treatment1, ", ", dataSet, "$", treatment2, ", ", dataSet, "$", effect, ", ", dataSet, "$", se, "),]", sep="")) }else{ doItAndPrint(paste("TempDF <- subset(", dataSet, ", subset=", subset, ")[complete.cases(subset(", dataSet, ", subset=", subset, ")$", treatment1, ", subset(", dataSet, ", subset=", subset, ")$", treatment2, ", subset(", dataSet, ", subset=", subset, ")$", effect, ", subset(", dataSet, ", subset=", subset, ")$", se, "),]", sep="")) } treatmentList <- eval(parse(text=paste("c(as.character(TempDF$", treatment1, "), as.character(TempDF$", treatment2, "))", sep=""))) if (!(reference %in% treatmentList)) { errorCondition(recall=StatMedNetworkMeta, message=gettextRcmdr("Reference treatment name not included")) return() } # library(meta, quietly=TRUE) Library("netmeta") doItAndPrint("res <- NULL") if (endpoint %in% c("OR", "HR")) { doItAndPrint(paste("TempDF$", se, " <- (log(TempDF$", se, ") - log(TempDF$", effect, ")) / qnorm(0.975)", sep="")) doItAndPrint(paste("TempDF$", effect, " <- log(TempDF$", effect, ")", sep="")) } if (connection==1){ doItAndPrint(paste("netconnection(", treatment1, ", ", treatment2, ", ", studyname, ", data=TempDF)", sep="")) } doItAndPrint(paste("res <- netmeta(", effect, ", ", se, ", ", treatment1, ", ", treatment2, ", ", studyname, ', data=TempDF, sm="', endpoint, '", reference.group="', reference, '", tol.multiarm=0.05, tol.multiarm.se=0.05)', sep="")) if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("netgraph(res)") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint('forest(res, sortvar=TE, pooled="random")') doItAndPrint("summary(res)") if(netrank==1){ doItAndPrint("(rank <- netrank(res))") if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint('par(lwd=1, las=2, family="sans", cex=1)') doItAndPrint('mar <- par("mar")') doItAndPrint("mar[1] <- mar[1] + 2") doItAndPrint("par(mar=mar)") doItAndPrint("opar <- par(mar = mar)") doItAndPrint("on.exit(par(opar))") doItAndPrint(paste('OrderedPlot(rank$Pscore.fixed, group=NULL, type="box", ylab="', endpoint, '", ylog=FALSE, decreasing="TRUE")', sep="")) } if(heat==1){ if (.Platform$OS.type == 'windows'){doItAndPrint(paste("windows(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else if (MacOSXP()==TRUE) {doItAndPrint(paste("quartz(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} else {doItAndPrint(paste("x11(", get("window.type", envir=.GlobalEnv), "); par(", get("par.option", envir=.GlobalEnv), ")", sep=""))} doItAndPrint("netheat(res, random=T, showall=T)") } if(split==1){ doItAndPrint("netsplit(res)") } tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="netmeta", apply="StatMedNetworkMeta", reset="StatMedNetworkMeta") tkgrid(getFrame(studynameBox), sticky="nw") tkgrid(getFrame(treatment1Box), labelRcmdr(variablesFrame, text=" "), getFrame(treatment2Box), sticky="nw") tkgrid(variablesFrame, sticky="nw") tkgrid(getFrame(effectBox), labelRcmdr(variables2Frame, text=" "), getFrame(seBox), sticky="nw") tkgrid(variables2Frame, sticky="nw") # tkgrid(labelRcmdr(variables2Frame, text=gettextRcmdr( "HR/OR for Treatment effect and 95% upper CI for SE to evaluate HR/OR."), fg="blue"), sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr( "Input OR/RR/HR for Treatment effect and 95% upper CI for SE to evaluate OR/RR/HR."), fg="blue"), sticky="w") tkgrid(labelRcmdr(referenceFrame, text=gettextRcmdr("Name of the reference treatment:")), referenceField, sticky = "w") tkgrid(referenceFrame, sticky="w") tkgrid(refFrame, sticky="w") tkgrid(optionsFrame, endpointFrame, sticky="w") tkgrid(subsetFrame, sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=7, columns=1) } EZRVersion <- function(){ initializeDialog(title=gettextRcmdr("EZR version")) onOK <- function(){ closeDialog() tkfocus(CommanderWindow()) } OKCancelHelp(helpSubject="Rcmdr") tkgrid(labelRcmdr(top, text=gettextRcmdr(" EZR on R commander (programmed by Y.Kanda) "), fg="blue"), sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr(" "), fg="blue"), sticky="w") tkgrid(labelRcmdr(top, text=paste(" ", gettextRcmdr("Current version:"), " 1.55", sep="")), sticky="w") tkgrid(labelRcmdr(top, text=paste(" ", gettextRcmdr("December 24, 2021"), sep="")), sticky="w") tkgrid(labelRcmdr(top, text=gettextRcmdr(" "), fg="blue"), sticky="w") tkgrid(buttonsFrame, sticky="w") dialogSuffix(rows=6, columns=1) } StatMedCloseCommander <- function() StatMedcloseCommander(ask=getRcmdr("ask.to.exit"), ask.save=getRcmdr("ask.on.exit")) StatMedcloseCommanderAndR <- function(){ response <- StatMedCloseCommander() if (response == "cancel") return() cat("\n") quit(save="no") } #StatMedcloseCommander <- function(ask=TRUE, ask.save=ask){ # if (ask){ # response <- tclvalue(RcmdrTkmessageBox(message=gettextRcmdr("Exit?"), # icon="question", type="okcancel", default="cancel")) # if (response == "cancel") return(invisible(response)) # } # else { # ask.save=FALSE # response <- "ok" # } # sink(type="message") ###add save data function # if (ask.save && !is.null(ActiveDataSet())){ # # logger("Active dataset") # response1 <- RcmdrTkmessageBox(message=gettextRcmdr("Save active dataset?"), # icon="question", type="yesno", default="yes") # if ("yes" == tclvalue(response1)){ # file <- tclvalue(tkgetSaveFile(filetypes= # gettextRcmdr('{"All Files" {"*"}} {"R Data Files" {".rda" ".Rda" ".RDA" ".RData"}}'), # defaultextension="rda", initialfile=paste(activeDataSet(), "rda", sep="."))) # if (file == "") return() # command <- paste('save("', activeDataSet(), '", file="', file, '")', sep="") # justDoIt(command) # logger(command) # } # } # if (!is.null(ActiveDataSet()) && getRcmdr("attach.data.set")) # justDoIt(logger(paste("detach(", ActiveDataSet(), ")", sep=""))) # putRcmdr(".activeDataSet", NULL) # putRcmdr(".activeModel", NULL) # if (ask.save && getRcmdr("log.commands") && tclvalue(tkget(LogWindow(), "1.0", "end")) != "\n"){ # response2 <- RcmdrTkmessageBox(message=gettextRcmdr("Save script file?"), # icon="question", type="yesno", default="yes") # if ("yes" == tclvalue(response2)) saveLog() # # if (ask.save && !getRcmdr("console.output") && tclvalue(tkget(OutputWindow(), "1.0", "end")) != "\n"){ # response3 <- RcmdrTkmessageBox(message=gettextRcmdr("Save output file?"), # icon="question", type="yesno", default="yes") # if ("yes" == tclvalue(response3)) saveOutput() # } # if (.Platform$OS.type != "windows") options(getRcmdr("oldPager")) # if (getRcmdr("suppress.X11.warnings")) { # sink(type = "message") # close(getRcmdr("messages.connection")) # } # options(getRcmdr("saveOptions")) # tkdestroy(CommanderWindow()) # putRcmdr("commanderWindow", NULL) # putRcmdr("logWindow", NULL) # putRcmdr("messagesWindow", NULL) # putRcmdr("outputWindow", NULL) # options(getRcmdr("quotes")) # tkwait <- options("Rcmdr")[[1]]$tkwait # to address problem in Debian Linux # if ((!is.null(tkwait)) && tkwait) putRcmdr(".commander.done", tclVar("1")) # return(invisible(response)) #} StatMedcloseCommander <- function(ask=TRUE, ask.save=ask){ ###add save data function if (!is.null(ActiveDataSet())){ logger("Active_dataset") response1 <- RcmdrTkmessageBox(message=gettextRcmdr("Save active dataset?"), icon="question", type="yesno", default="yes") if ("yes" == tclvalue(response1)){ file <- tclvalue(tkgetSaveFile(filetypes= gettextRcmdr('{"All Files" {"*"}} {"R Data Files" {".rda" ".Rda" ".RDA" ".RData"}}'), defaultextension="rda", initialfile=paste(activeDataSet(), "rda", sep="."))) if (file == "") return() command <- paste('save("', activeDataSet(), '", file="', file, '")', sep="") justDoIt(command) logger(command) } } closeCommander(ask=TRUE, ask.save=ask) # closeCommander() } EZRhelp <- function(){ flag <- 0 for(i in search()) if(i=="package:RcmdrPlugin.EZR")flag <- 1 if(flag==0){ doItAndPrint('browseURL(paste(file.path(path.package(package="Rcmdr"), "doc"), "/", "EZR.htm", sep=""))') }else{ doItAndPrint("help(EZR)") } } EZR <- function(){ cat(gettextRcmdr("EZR on R commander (programmed by Y.Kanda) Version 1.55", "\n")) } if (getRversion() >= '2.15.1') globalVariables(c('top', 'buttonsFrame', 'TempTD', 'actmodelVariable', 'subsetVariable', 'subsetFrame', 'oneWayAnova', 'graphVariable', 'pairwiseVariable', 'dunnettVariable', 'bonferroniVariable', 'holmVariable', 'graphFrame', 'lineVariable', 'placeVariable', 'censorVariable', 'atriskVariable', 'xscaleVariable', 'lineFrame', 'placeFrame', 'xscaleFrame', 'censor', 'atrisk', 'colorVariable', 'besideVariable', 'percentVariable', 'errorBarsVariable', 'errorBarsFrame', 'levelsVariable', 'binVariable', 'methodVariable', 'subdialog', 'subButtonsFrame', 'entry1', 'onCancel', 'levelNames', 'levelsFrame', 'methodFrame', 'logyVariable', 'whiskerVariable', 'logy', 'whiskerFrame', 'lhsVariable', 'rhsVariable', 'onHelp', 'xBox', 'outerOperatorsFrame', 'formulaFrame', 'checkboxFrame', 'lhsEntry', 'paletteVariable', 'paletteFrame', 'alternativeVariable', 'alternativeFrame', 'waldVariable', 'prophazVariable', 'basecurveVariable', 'stepwise1Variable', 'stepwise2Variable', 'stepwise3Variable', 'SurvivalTimeVariable', 'StatusVariable', 'posthocVariable', 'posthocFrame', 'ymdVariable', 'ymdFrame', 'percentsVariable', 'chisqVariable', 'chisqComponentsVariable', 'expFreqVariable', 'fisherVariable', '.Test', '.Table', 'percentsFrame', 'testsFrame', 'optionsFrame', 'delimiterFrame', 'delimiterVariable', 'colnamesVariable', 'rownamesVariable', 'quotesVariable', 'numericToFactor', 'filterNA', 'subwin', '.Probs', '.Responses', 'window.sizeVariable', 'window.typeVariable', 'lwdVariable', 'lasVariable', 'familyVariable', 'cexVariable', 'window.sizeFrame', 'window.typeFrame', 'lwdFrame', 'lasFrame', 'familyFrame', 'cexFrame', 'scaleVariable', 'color', 'scaleFrame', 'importMinitab', 'importRODBCtable', 'importSPSS', 'importSTATA', 'ciVariable', 'separatestrataVariable', 'testVariable', 'testFrame', 'steeldwassVariable', 'steelVariable', 'logVariable', 'multiVariable', 'y', 'linearRegressionModel', 'helpButton', 'baseVariable', 'baseFrame', 'continuityVariable', 'continuityFrame', 'endpointVariable', 'dslVariable', 'detailVariable', 'funnelVariable', 'endpointFrame', 'inputVariable', 'inputFrame', 'interactionVariable', 'numbersButton', 'namesButton', 'meanVariable', 'sdVariable', '.groups', 'checkBoxFrame', 'groupsFrame', 'unmatchVariable', 'unmatchFrame', 'typeVariable', 'trendVariable', 'typeFrame', 'trendFrame', 'chisqTestVariable', 'exactTestVariable', 'directionVariable', 'bestVariable', 'thresholdVariable', 'directionFrame', 'bestFrame', 'locationVariable', 'decimalVariable', 'locationFrame', 'decimalFrame', 'renameVariables', 'chrtofacVariable', 'chrtofac', 'reorderFactor', 'removeVariable', 'removeFrame', 'twostageVariable', 'twostage', 'jitterXVariable', 'jitterYVariable', 'logXVariable', 'logYVariable', 'identifyVariable', 'boxplotsVariable', 'lsLineVariable', 'smoothLineVariable', 'spreadVariable', 'scatterPlot', 'diagonalVariable', 'diagonalFrame', 'StaMedSetContrasts', 'contrastsVariable', 'contrastsFrame', '..', 'hex.1', 'hex.2', 'hex.3', 'hex.4', 'hex.5', 'hex.6', 'hex.7', 'hex.8', 'decreasingVariable', 'decreasingFrame', 'Stack', 'partsVariable', 'styleVariable', 'trimOutliersVariable', 'showDepthsVariable', 'reverseNegativeVariable', 'partsFrame', 'styleFrame', 'variancesVariable', 'variancesFrame', 'fisherTestVariable', 'saveLog', 'saveOutput', '.commander.done', 'ci.summary.table', 'cox.table', 'km.summary.table', 'summary.ttest', 'Fisher.summary.table', 'StatMedcloseCommander', 'hist2', 'separatestrata', 'diagnosisVariable', 'martinVariable', 'res', 'HistEZR', 'QQPlot', '.Workbook', 'par.lwd', 'par.cex', 'getSheets', 'analysisVariable', 'outputVariable', 'languageVariable', 'analysisFrame', 'outputFrame', 'languageFrame', 'exactVariable', 'rangeVariable', 'explainVariable', 'exactFrame', 'rangeFrame', 'explainFrame', 'multireg.table', 'smdVariable', 'survfit', 'survdiff', 'odbcCloseAll', 'odbcConnectExcel', 'odbcConnectExcel2007', 'odbcConnectAccess', 'odbcConnectAccess2007', 'odbcConnectDbase', 'sqlTables', '.Tcl.args', 'cuminc', 'Anova', 'pmvt', 'wald.test', 'timepoints', 'ci', 'sqlQuery', 'groupingVariable', 'groupingFrame', 'othervarVariable', 'rocVariable', 'columnmergeVariable', 'column.name1', 'column.name2', 'columnmergeFrame', 'deleteVariable', 'RecodeDialog', 'km', 'coxmodel', 'pscoreVariable', 'ypercent', 'ypercentVariable', 'caliperVariable', 'caliperFrame', 'predictorVariale', 'predicorFrame', 'linearMixedModel', 'pvalueVariable', 'estimTypeVariable', 'estimTypeFrame', 'numSummary', 'num', 'lev', 'smd', 'smdFrame', 'iptwVariable', 'connectionVariable', 'netrankVariable', 'heatVariable', 'splitVariable', 'modelTypeFrame', 'modelTypeVariable', 'weight.ATE', 'estimationVariable', 'varVariable', 'estimationFrame', 'clfs', 'lines', 'com.estVariable', 'colVariable', 'cciVariable', 'selection', 'com.est', 'cci', 'swimmer_plot', 'swimmer_arrows', 'scale_fill_grey', 'swimmer_points', 'currentSurvival', 'swimplot', 'ggplot2', ''))