relimp/0000755000175100001440000000000011647073434011571 5ustar hornikusersrelimp/man/0000755000175100001440000000000011646767060012350 5ustar hornikusersrelimp/man/relimp.Rd0000644000175100001440000001104111441531371014107 0ustar hornikusers\name{relimp} \alias{relimp} \alias{print.relimp} \title{Relative Importance of Predictors in a Regression Model} \description{ Produces a summary of the relative importance of two predictors or two sets of predictors in a fitted model object. } \usage{ relimp(object, set1=NULL, set2=NULL, label1="set1", label2="set2", subset=TRUE, response.cat=NULL, \dots) \method{print}{relimp}(x, digits=3, \dots) } \arguments{ \item{object}{A model object of class \code{\link{lm}}, \code{\link{glm}}, \code{\link[survival]{coxph}}, \code{\link[survival]{survreg}}, \code{\link[nnet]{multinom}}, \code{\link[MASS]{polr}} or \code{\link[nlme]{gls}}} \item{set1}{An index or vector of indices for the effects to be included in the numerator of the comparison} \item{set2}{An index or vector of indices for the effects to be included in the denominator of the comparison} \item{label1}{A character string; mnemonic name for the variables in \code{set1}} \item{label2}{A character string; mnemonic name for the variables in \code{set2}} \item{subset}{Either a vector of numeric indices for the cases to be included in the standardization of effects, or a vector of logicals (\code{TRUE} for inclusion) whose length is the same as the number of rows in the model frame, \code{object$model}. The default choice is to include all cases in the model frame.} \item{response.cat}{If \code{object} is of class \code{multinom}, this is a character string used to specify which regression is of interest (i.e., the regression which predicts the log odds on \code{response cat} versus the model's reference category). The \code{response.cat} argument should be an element of \code{object$lab}; or \code{NULL} if \code{object} is not of class \code{multinom}.} \item{\dots}{For models of class \code{glm}, one may additionally set the dispersion parameter for the family (for example, \code{dispersion=1.69}). By default it is obtained from \code{object}. Supplying it here permits explicit allowance for over-dispersion, for example.} \item{x}{an object of class \code{relimp}} \item{digits}{The number of decimal places to be used in the printed summary. Default is 3.} } \details{If \code{set1} and \code{set2} both have length 1, relative importance is measured by the ratio of the two standardized coefficients. Equivalently this is the ratio of the standard deviations of the two contributions to the linear predictor, and this provides the generalization to comparing two sets rather than just a pair of predictors. The computed ratio is the square root of the variance-ratio quantity denoted as `omega' in Silber, J H, Rosenbaum, P R and Ross, R N (1995). Estimated standard errors are calculated by the delta method, as described in that paper for example. If \code{set1} and \code{set2} are unspecified, and if the \code{tcltk} package has been loaded, a dialog box is provided (by a call to \code{\link{pickFrom}}) for the choice of \code{set1} and \code{set2} from the available model coefficients. } \value{ An object of class \code{relimp}, with at least the following components: \item{model}{The call used to construct the model object summarized} \item{sets}{The two sets of indices specified as arguments} \item{log.ratio}{The natural logarithm of the ratio of effect standard deviations corresponding to the two sets specified} \item{se.log.ratio}{An estimated standard error for log.ratio} If \code{dispersion} was supplied as an argument, its value is stored as the \code{dispersion} component of the resultant object. } \references{Silber, J. H., Rosenbaum, P. R. and Ross, R N (1995) Comparing the Contributions of Groups of Predictors: Which Outcomes Vary with Hospital Rather than Patient Characteristics? \emph{JASA} \bold{90}, 7--18. } \author{David Firth \email{d.firth@warwick.ac.uk} } \seealso{\code{\link{relrelimp}}} \examples{ x <- rnorm(100) z <- rnorm(100) w <- rnorm(100) y <- 3+ 2*x + z + w + rnorm(100) test <- lm(y ~ x +z +w) print(test) relimp(test, 2, 3) # compares effects of x and z relimp(test, 2, 3:4) # compares effect of x with that of (z,w) combined ## ## Data on housing and satisfaction, from Venables and Ripley ## -- multinomial logit model library(MASS) library(nnet) data(housing) house.mult <- multinom(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) relimp(house.mult, set1 = 2:3, set2 = 7, response.cat = "High") } \keyword{models} \keyword{regression} relimp/man/R.to.Tcl.Rd0000644000175100001440000000067710454663106014204 0ustar hornikusers\name{R.to.Tcl} \alias{R.to.Tcl} \title{Convert a Character Vector to Tcl Format } \description{ Converts a character vector into a brace-delimited Tcl list } \usage{ R.to.Tcl(character.vector) } \arguments{ \item{character.vector}{A character vector} } \value{ A character vector of length 1 } \author{David Firth, \email{d.firth@warwick.ac.uk}} \seealso{\code{\link{Tcl.to.R}}} \examples{ R.to.Tcl(c("apple","banana")) } \keyword{utilities} relimp/man/relrelimp.Rd0000644000175100001440000000735310454663106014632 0ustar hornikusers\name{relrelimp} \alias{relrelimp} \title{Comparison of Relative Importances in a Multinomial Logit Model} \description{ Produces a summary of the relative importance of two predictors or two sets of predictors in a fitted \code{\link[nnet]{multinom}} model object, and compares relative importances across two of the fitted logit models. } \usage{ relrelimp(object, set1=NULL, set2=NULL, label1="set1", label2="set2", subset=TRUE, response.cat1=NULL, response.cat2=NULL) } \arguments{ \item{object}{A model object of class \code{multinom}} \item{set1}{An index or vector of indices for the effects to be included in the numerator of the comparison} \item{set2}{An index or vector of indices for the effects to be included in the denominator of the comparison} \item{label1}{A character string; mnemonic name for the variables in \code{set1}} \item{label2}{A character string; mnemonic name for the variables in \code{set2}} \item{subset}{Either a vector of numeric indices for the cases to be included in the standardization of effects, or a vector of logicals (\code{TRUE} for inclusion) whose length is the same as the number of rows in the model frame, \code{object$model}. The default choice is to include all cases in the model frame.} \item{response.cat1}{A character string used to specify the first regression of interest (i.e., the regression which predicts the log odds on \code{response.cat1} versus the model's reference category). The \code{response.cat1} argument should be an element of \code{object$lab}.} \item{response.cat2}{A character string used to specify the second regression of interest (i.e., the regression which predicts the log odds on \code{response.cat2} versus the model's reference category). The \code{response.cat2} argument should be an element of \code{object$lab}.} } \details{Computes a relative importance summary as described in \code{\link{relimp}}, for each of the two regressions specified by \code{response.cat1} and \code{response.cat2} (relative to the same reference category); and computes the difference of those two relative importance summaries, along with an estimated standard error for that difference. } \value{ An object of class \code{relrelimp}, with at least the following components: \item{model}{The call used to construct the model object summarized} \item{sets}{The two sets of indices specified as arguments} \item{response.category}{A character vector containing the specified \code{response.cat1} and \code{response.cat2}} \item{log.ratio}{The natural logarithm of the ratio of effect standard deviations corresponding to the two sets specified. A vector with three components: the first is for \code{response.cat1} versus the reference category, the second for \code{response.cat2} versus the reference category, the third is the difference.} \item{se.log.ratio}{Estimated standard errors for the elements of \code{log.ratio}} } \author{David Firth, \email{d.firth@warwick.ac.uk} } \seealso{\code{\link{relimp}}} \examples{ ## Data on housing and satisfaction, from Venables and Ripley library(MASS) library(nnet) data(housing) house.mult <- multinom(Sat ~ Infl + Type + Cont, weights = Freq, data = housing) relrelimp(house.mult, set1 = 2:3, set2 = 7, label1 = "Influence", label2 = "Contact", response.cat1 = "Medium", response.cat2 = "High") ## Computes the relative contribution of Influence and Contact in ## each of the two logistic regressions (Med/Low and High/Low), and ## compares those two relative-contribution measures. } \keyword{models} \keyword{regression} relimp/man/showData.Rd0000644000175100001440000000535410501534557014410 0ustar hornikusers\name{showData} \alias{showData} \title{Display a Data Frame in a Tk Text Widget} \description{ Displays the contents of a data frame in a modeless Tk text window, for inspection. Objects not of class \code{data.frame}, for example objects of class \code{table}, or \code{matrix}, are coerced using \code{as.data.frame} prior to display. } \usage{ showData(dataframe, colname.bgcolor = "grey50", rowname.bgcolor = "grey50", body.bgcolor = "white", colname.textcolor = "white", rowname.textcolor = "white", body.textcolor = "black", font = "Courier 12", maxheight = 30, maxwidth = 80, title = NULL, rowname.bar = "left", colname.bar = "top", rownumbers = FALSE, placement = "-20-40", suppress.X11.warnings = TRUE) } \arguments{ \item{dataframe}{A data frame, or an object to which \code{as.data.frame()} can be validly applied} \item{colname.bgcolor}{A background colour for the variable-names panel} \item{rowname.bgcolor}{A background colour for the row-names panel} \item{body.bgcolor}{A background colour for the data} \item{colname.textcolor}{A colour for the variable names} \item{rowname.textcolor}{A colour for the row names} \item{body.textcolor}{A colour for the data} \item{font}{The text font used -- should be a monospaced font} \item{maxheight}{The maximum number of rows to display} \item{maxwidth}{The maximum width of display, in characters} \item{title}{A title for the window. Default is to use the name of the dataframe as given in the call to \code{showData()}} \item{rowname.bar}{position of sidebar for row names, \code{"left"} or \code{"right"}, or \code{c("left","right")}, or \code{NULL}} \item{colname.bar}{position of column names, \code{"top"} or \code{"bottom"}, or \code{c("top","bottom")}, or \code{NULL}} \item{rownumbers}{logical, whether row numbers should be displayed} \item{placement}{Position of the bottom right corner of the window} \item{suppress.X11.warnings}{logical, if \code{TRUE} then any X11 warnings are suppressed} } \value{ \code{invisible(NULL)} } \note{An error results if the printed representation of \code{dataframe} exceeds the maximum allowed width of 10000 characters; see \code{\link{options}}. Text can be copied from the Tk window to the system clipboard, using or via a right-click pop-up menu. On some systems the window may take a few seconds to appear if the data frame is very large. } \author{David Firth, \email{d.firth@warwick.ac.uk}} \examples{ ## This cannot be run by example() but should be OK when pasted ## into an interactive R session \dontrun{ data(mtcars) showData(mtcars)} } \keyword{utilities} relimp/man/Tcl.to.R.Rd0000644000175100001440000000065510454663106014200 0ustar hornikusers\name{Tcl.to.R} \alias{Tcl.to.R} \title{Convert a Tcl List to R Character Vector} \description{ Converts a brace-delimited list from Tcl into a character vector } \usage{ Tcl.to.R(tcl.list) } \arguments{ \item{tcl.list}{a character string} } \value{ a character vector } \author{David Firth, \email{d.firth@warwick.ac.uk}} \seealso{\code{\link{R.to.Tcl}}} \examples{ Tcl.to.R("{apple} {banana} {pear}") } \keyword{utilities} relimp/man/pickFrom.Rd0000644000175100001440000000721511021454067014401 0ustar hornikusers\name{pickFrom} \alias{pickFrom} \title{Pick Subsets from a Vector} \description{ Provides a Tk dialog or a text-based menu for interactive selection of one or more subsets from a vector. } \usage{ pickFrom(vec, nsets = 1, return.indices = FALSE, setlabels = NULL, edit.setlabels = TRUE, subset = TRUE, warningText = "one or more selections empty", title = "Subset picker", items.label = "Pick from", labels.prompt = "Your label for this set", list.height = 20, items.scrollbar = TRUE, preserve.order = TRUE, graphics = TRUE, listFont = "Courier 12", labelFont = "Helvetica 11", windowPos = "+150+30") } \arguments{ \item{vec}{a vector} \item{nsets}{a positive integer, the number of subsets to be selected} \item{return.indices}{logical, whether indices (\code{TRUE}) or vector contents (\code{FALSE}) are to be returned} \item{setlabels}{a character vector of labels for the subsets} \item{edit.setlabels}{logical, determines whether a textbox is provided for editing the label of each subset} \item{subset}{logical, character or numeric vector indicating which elements of \code{vec} should be made available for selection. Default is to make all elements available.} \item{warningText}{character, text to use as a warning in situations where no selection is made into one or more of the specified sets} \item{title}{character, title of the Tk dialog window} \item{items.label}{character, a label for the set of items to be selected from} \item{labels.prompt}{character, a prompt for textual set label(s)} \item{list.height}{maximum number of elements of \code{vec} to display at once} \item{items.scrollbar}{logical, whether a scrollbar is to be provided when \code{vec} is longer than \code{list.height}} \item{preserve.order}{logical: should the order of items in \code{vec} be maintained in all of the returned subsets?} \item{graphics}{logical: should a dialog be used, if possible?} \item{listFont}{a Tk font specification for the items list and subsets} \item{labelFont}{a Tk font specification for the labels entrybox} \item{windowPos}{position of the Tk dialog, in pixels from top left of display} } \details{ If \code{graphics = TRUE} and the \code{tcltk} package is operational, a Tk dialog is used, otherwise a text menu. If \code{return.indices} is used together with \code{subset}, the indices returned relate to \code{vec}, not to \code{vec[subset]}. } \value{ EITHER (in the case of a text menu or if the dialog is ended with "OK") a list, with \code{nsets} components. Each component is a selected sub-vector, or a numeric vector of indices for a selected sub-vector (if \code{return.indices} is \code{TRUE}). The component names are as specified in \code{setlabels}, or as specified interactively. OR (if the dialog is ended either "Cancel" or the close-window control button is used) \code{NULL}. } \author{David Firth, with contributions from Heather Turner} \examples{ ## These examples cannot be run by example() but should be OK when pasted ## into an interactive R session \dontrun{ pickFrom(c("apple", "banana", "plum", "grapefruit"), nsets = 2, preserve.order = FALSE, setlabels = c("Fruits I like", "Fruits I tolerate")) } \dontrun{ ## Type selections as e.g. 1:2, 4 pickFrom(c("apple", "banana", "plum", "grapefruit"), nsets = 2, preserve.order = FALSE, setlabels = c("Fruits I like", "Fruits I tolerate"), graphics = FALSE) }} \keyword{utilities} relimp/R/0000755000175100001440000000000011646767060011776 5ustar hornikusersrelimp/R/showData.R0000644000175100001440000003006511035650324013661 0ustar hornikusersR.to.Tcl <- function (character.vector) ## converts a character vector into a brace-delimited Tcl list { if (length(character.vector) == 0) list() else paste("{", paste(character.vector, collapse = "} {"), "}", sep = "") } Tcl.to.R <- function (tcl.list) ## converts a fully brace-delimited Tcl list into a character ## vector in R { tcl.list <- substring(tcl.list, 2, nchar(tcl.list) - 1) strsplit(tcl.list, split = "} {", fixed = TRUE)[[1]] } "showData" <- function (dataframe, colname.bgcolor = "grey50", rowname.bgcolor = "grey50", body.bgcolor = "white", colname.textcolor = "white", rowname.textcolor = "white", body.textcolor = "black", font = "Courier 12", maxheight = 30, maxwidth = 80, title = NULL, rowname.bar = "left", colname.bar = "top", rownumbers = FALSE, placement = "-20-40", suppress.X11.warnings = TRUE) { object.name <- deparse(substitute(dataframe)) if (!is.data.frame(dataframe)){ temp <- try(dataframe <- as.data.frame(dataframe), silent = FALSE) if (inherits(temp, "try-error")) { stop(paste(object.name, "cannot be coerced to a data frame")) } object.name <- paste("as.data.frame(", object.name, ")", sep = "") } if (is.numeric(rownumbers) && length(rownumbers) != nrow(dataframe)) { stop("rownumbers argument must be TRUE, FALSE or have length nrow(dataframe)") } # require(tcltk) || stop("Tcl/Tk support is absent") ## now "Imports:" oldwidth <- unlist(options("width")) options(width = 10000) conn <- file() sink(conn) print(dataframe) sink() zz <- scan(conn, sep = "\n", what = character(0), quiet = TRUE) close(conn) if (length(zz) > 1 + nrow(dataframe)) stop( "data frame too wide") options(width = oldwidth) if (suppress.X11.warnings) { ## as in John Fox's Rcmdr package messages.connection <- textConnection(".messages", open = "w", local = TRUE) sink(messages.connection, type = "message") on.exit({ sink(type="message") close(messages.connection) }) } base <- tktoplevel() tkwm.geometry(base, placement) tkwm.title(base, { if (is.null(title)) object.name else title }) nrows <- length(zz) - 1 if (is.numeric(rownumbers)) rowname.text <- paste(rownumbers, row.names(dataframe)) else if (rownumbers) rowname.text <- paste(1:nrows, row.names(dataframe)) else rowname.text <- row.names(dataframe) namewidth = max(nchar(rowname.text)) yy <- substring(zz, 2 + max(nchar(row.names(dataframe)))) datawidth <- max(nchar(yy)) winwidth <- min(1 + datawidth, maxwidth) hdr <- tktext(base, bg = colname.bgcolor, fg = colname.textcolor, font = font, height = 1, width = winwidth, takefocus = TRUE) ftr <- tktext(base, bg = colname.bgcolor, fg = colname.textcolor, font = font, height = 1, width = winwidth, takefocus = TRUE) textheight <- min(maxheight, nrows) txt <- tktext(base, bg = body.bgcolor, fg = body.textcolor, font = font, height = textheight, width = winwidth, setgrid = 1, takefocus = TRUE) lnames <- tktext(base, bg = rowname.bgcolor, fg = rowname.textcolor, font = font, height = textheight, width = namewidth, takefocus = TRUE) rnames <- tktext(base, bg = rowname.bgcolor, fg = rowname.textcolor, font = font, height = textheight, width = namewidth, takefocus = TRUE) xscroll <- tkscrollbar(base, orient = "horizontal", repeatinterval = 1, command = function(...) { tkxview(txt, ...) tkxview(hdr, ...) tkxview(ftr, ...) }) string.to.vector <- function(string.of.indices) { string.of.indices <- tclvalue(string.of.indices) as.numeric(strsplit(string.of.indices, split = " ")[[1]]) } tkconfigure(txt, xscrollcommand = function(...) { tkset(xscroll, ...) xy <- string.to.vector(tkget(xscroll)) tkxview.moveto(hdr, xy[1]) tkxview.moveto(ftr, xy[1]) }) tkconfigure(hdr, xscrollcommand = function(...) { tkset(xscroll, ...) xy <- string.to.vector(tkget(xscroll)) tkxview.moveto(txt, xy[1]) tkxview.moveto(ftr, xy[1]) }) tkconfigure(ftr, xscrollcommand = function(...) { tkset(xscroll, ...) xy <- string.to.vector(tkget(xscroll)) tkxview.moveto(hdr, xy[1]) tkxview.moveto(txt, xy[1]) }) yscroll <- tkscrollbar(base, orient = "vertical", repeatinterval = 1, command = function(...) { tkyview(txt, ...) tkyview(lnames, ...) tkyview(rnames, ...) }) tkconfigure(txt, yscrollcommand = function(...) { tkset(yscroll, ...) xy <- string.to.vector(tkget(yscroll)) tkyview.moveto(lnames, xy[1]) tkyview.moveto(rnames, xy[1]) }) tkconfigure(lnames, yscrollcommand = function(...) { tkset(yscroll, ...) xy <- string.to.vector(tkget(yscroll)) tkyview.moveto(txt, xy[1]) tkyview.moveto(rnames, xy[1]) }) tkconfigure(rnames, yscrollcommand = function(...) { tkset(yscroll, ...) xy <- string.to.vector(tkget(yscroll)) tkyview.moveto(txt, xy[1]) tkyview.moveto(lnames, xy[1]) }) tkbind(txt, "", function(x, y) { tkscan.dragto(txt, x, y) }) ## The next block just enables copying from the text boxes { copyText.hdr <- function(){ tcl("event", "generate", .Tk.ID(hdr), "<>")} tkbind(hdr, "", function() tkfocus(hdr)) editPopupMenu.hdr <- tkmenu(hdr, tearoff = FALSE) tkadd(editPopupMenu.hdr, "command", label = "Copy ", command = copyText.hdr) RightClick.hdr <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tkwinfo("rootx", hdr)) rooty <- as.integer(tkwinfo("rooty", hdr)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcl("tk_popup", editPopupMenu.hdr, xTxt, yTxt) } tkbind(hdr, "", RightClick.hdr) tkbind(hdr, "", copyText.hdr) ## copyText.ftr <- function(){ tcl("event", "generate", .Tk.ID(ftr), "<>")} tkbind(ftr, "", function() tkfocus(ftr)) editPopupMenu.ftr <- tkmenu(ftr, tearoff = FALSE) tkadd(editPopupMenu.ftr, "command", label = "Copy ", command = copyText.ftr) RightClick.ftr <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tkwinfo("rootx", ftr)) rooty <- as.integer(tkwinfo("rooty", ftr)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcl("tk_popup", editPopupMenu.ftr, xTxt, yTxt) } tkbind(ftr, "", RightClick.ftr) tkbind(ftr, "", copyText.ftr) ## copyText.txt <- function(){ tcl("event", "generate", .Tk.ID(txt), "<>")} tkbind(txt, "", function() tkfocus(txt)) editPopupMenu.txt <- tkmenu(txt, tearoff = FALSE) tkadd(editPopupMenu.txt, "command", label = "Copy ", command = copyText.txt) RightClick.txt <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tkwinfo("rootx", txt)) rooty <- as.integer(tkwinfo("rooty", txt)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcl("tk_popup", editPopupMenu.txt, xTxt, yTxt) } tkbind(txt, "", RightClick.txt) tkbind(txt, "", copyText.txt) ## copyText.lnames <- function(){ tcl("event", "generate", .Tk.ID(lnames), "<>")} tkbind(lnames, "", function() tkfocus(lnames)) editPopupMenu.lnames <- tkmenu(lnames, tearoff = FALSE) tkadd(editPopupMenu.lnames, "command", label = "Copy ", command = copyText.lnames) RightClick.lnames <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tkwinfo("rootx", lnames)) rooty <- as.integer(tkwinfo("rooty", lnames)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcl("tk_popup", editPopupMenu.lnames, xTxt, yTxt) } tkbind(lnames, "", RightClick.lnames) tkbind(lnames, "", copyText.lnames) ## copyText.rnames <- function(){ tcl("event", "generate", .Tk.ID(rnames), "<>")} tkbind(rnames, "", function() tkfocus(rnames)) editPopupMenu.rnames <- tkmenu(rnames, tearoff = FALSE) tkadd(editPopupMenu.rnames, "command", label = "Copy ", command = copyText.rnames) RightClick.rnames <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tkwinfo("rootx", rnames)) rooty <- as.integer(tkwinfo("rooty", rnames)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcl("tk_popup", editPopupMenu.rnames, xTxt, yTxt) } tkbind(rnames, "", RightClick.rnames) tkbind(rnames, "", copyText.rnames) } tktag.configure(hdr, "notwrapped", wrap = "none") tktag.configure(ftr, "notwrapped", wrap = "none") tktag.configure(txt, "notwrapped", wrap = "none") tktag.configure(lnames, "notwrapped", wrap = "none") tktag.configure(rnames, "notwrapped", wrap = "none") tkinsert(txt, "end", paste(paste(yy[-1], collapse = "\n"), sep = ""), "notwrapped") tkgrid(txt, row = 1, column = 1, sticky = "nsew") if ("top" %in% colname.bar) { tkinsert(hdr, "end", paste(yy[1], sep = ""), "notwrapped") tkgrid(hdr, row = 0, column = 1, sticky = "ew") } if ("bottom" %in% colname.bar) { tkinsert(ftr, "end", paste(yy[1], sep = ""), "notwrapped") tkgrid(ftr, row = 2, column = 1, sticky = "ew") } if ("left" %in% rowname.bar) { tkinsert(lnames, "end", paste(rowname.text, collapse = "\n"), "notwrapped") tkgrid(lnames, row = 1, column = 0, sticky = "ns") } if ("right" %in% rowname.bar) { tkinsert(rnames, "end", paste(rowname.text, collapse = "\n"), "notwrapped") tkgrid(rnames, row = 1, column = 2, sticky = "ns") } # tkconfigure(hdr, state = "disabled") # tkconfigure(ftr, state = "disabled") tkconfigure(txt, state = "disabled") tkconfigure(lnames, state = "disabled") tkconfigure(rnames, state = "disabled") if (maxheight < nrows) { tkgrid(yscroll, row = 1, column = 3, sticky = "ns") } if (maxwidth < datawidth) { tkgrid(xscroll, row = 3, column = 1, sticky = "ew") } tkgrid.rowconfigure(base, 1, weight = 1) tkgrid.columnconfigure(base, 1, weight = 1) tkwm.maxsize(base, 1 + datawidth, nrows) tkwm.minsize(base, 1 + nchar(names(dataframe)[1]), 1) invisible(NULL) } relimp/R/pickFrom.R0000644000175100001440000003267211021453422013662 0ustar hornikusers"pickFrom" <- function (vec, nsets = 1, return.indices = FALSE, setlabels = NULL, edit.setlabels = TRUE, subset = TRUE, warningText = "one or more selections empty", title = "Subset picker", items.label = "Pick from", labels.prompt = "Your label for this set", list.height = 20, items.scrollbar = TRUE, preserve.order = TRUE, graphics = TRUE, listFont = "Courier 12", labelFont = "Helvetica 11", windowPos = "+150+30") { if (!interactive()) stop("Attempt to use interactive selection function when R is not ", "running interactively") if (!is.vector(vec)) stop("argument `vec' muct be a vector") vec.is.numeric <- if (is.numeric(vec)) TRUE else FALSE vec.as.char <- as.character(vec) vec.to.pickfrom <- vec.as.char[subset] ni <- length(vec.to.pickfrom) if (is.character(subset)) subset <- match(subset(names(vec))) if (is.logical(subset)) subset <- seq(along = vec)[subset] setlabels <- if (!is.null(setlabels)) as.list(setlabels) else as.list(rep("", nsets)) items.label <- paste(items.label, ":", sep = "") if (graphics & capabilities("tcltk")) { ppp <- NULL ## only to avoid a NOTE at package check time string.to.vector <- function(string.of.indices) { as.numeric(strsplit(string.of.indices, split = " ")[[1]]) } base <- tktoplevel(takefocus = 1) tkwm.title(base, title) tkwm.geometry(base, windowPos) tkwm.resizable(base, 0, 0) right.frm <- tkframe(base) left.frm <- tkframe(base) items.list <- as.character(tclVar(paste("{", paste(vec.to.pickfrom, collapse = "} {"), "}", sep = ""))) items.frm <- tkframe(left.frm) items.label <- tklabel(items.frm, text = items.label, anchor = "w", justify = "left") tkgrid(items.label, row = 0, columnspan = 2, sticky = "w") items.height <- min(list.height, ni) items.width <- max(8, max(nchar(vec.to.pickfrom))) items <- tklistbox(items.frm, listvar = items.list, bg = "grey50", selectmode = "extended", fg = "white", font = listFont, width = items.width, height = items.height) tkgrid(items, row = 1, column = 0) preserve.order <- tclVar(as.numeric(preserve.order)) buttons.frm <- tkframe(left.frm) buttonA <- tkradiobutton(buttons.frm, text = "Sort sets in\nthe above order\nupon \"Add\"", justify = "left", variable = preserve.order, value = "1", command = function(){NULL} ) buttonB <- tkradiobutton(buttons.frm, text = "Place\nnewly added\nitems last", justify = "left", variable = preserve.order, value = "0", command = function(){NULL} ) if (items.scrollbar && (length(vec) > items.height)) { items.scrollbar <- tkscrollbar(items.frm, orient = "vertical", repeatinterval = 1, command = function(...) { tkyview(items, ...) }) tkconfigure(items, yscrollcommand = function(...) { tkset(items.scrollbar, ...) xy <- string.to.vector(tclvalue(tkget(items.scrollbar))) tkyview.moveto(items, xy[1]) }) tkgrid(items.scrollbar, row = 1, column = 1, sticky = "ns") } tkpack(buttonA, buttonB, pady = 1, padx = 5, side = "top", anchor = "nw") tkpack(items.frm, buttons.frm, pady = 1, padx = 5, side = "top") tkpack(left.frm, side = "top", expand = "true", anchor = "n") sets.frm <- tkframe(right.frm) setframe <- list() label <- list() setlabeltext <- list() labelentry <- list() TCLlabel <- list() listbox <- list() add.but <- list() labelbox <- list() listvarname <- list() remove.but <- list() tkset <- list() set <- list() Rtkset <- list() subset.height <- min(list.height - 5, ni) for (i in 1:nsets) { tkset[[i]] <- tclVar("") TCLlabel[[i]] <- tclVar(setlabels[[i]]) setframe[[i]] <- tkframe(sets.frm, width = 250, relief = "groove", borderwidth = 2) label[[i]] <- tklabel(setframe[[i]], text = setlabels[[i]]) listvarname[[i]] <- as.character(tkset[[i]]) listbox[[i]] <- tklistbox(setframe[[i]], listvar = listvarname[[i]], bg = "white", height = subset.height, font = listFont, width = items.width, selectmode = "extended") labelbox[[i]] <- tkframe(setframe[[i]], width = 250) setlabeltext[[i]] <- tklabel(labelbox[[i]], text = paste(labels.prompt, ":", sep = "")) } add.cmd <- deparse(function() { set[[ppp]] <- match(Tcl.to.R(tclvalue(tkset[[ppp]])), vec.to.pickfrom) set[[ppp]] <- union(set[[ppp]], 1 + string.to.vector(tclvalue(tkcurselection(items)))) if (as.logical(tclObj(preserve.order))) set[[ppp]] <- sort(set[[ppp]]) tclvalue(tkset[[ppp]]) <- R.to.Tcl(vec.to.pickfrom[set[[ppp]]]) tkconfigure(add.but[[ppp]], state = "disabled") }) remove.cmd <- deparse(function() { Rtkset[[ppp]] <- Tcl.to.R(tclvalue(tkset[[ppp]])) out <- 1 + string.to.vector(tclvalue(tkcurselection(listbox[[ppp]]))) if (length(Rtkset[[ppp]]) == length(out)) tclvalue(tkset[[ppp]]) <- "" else tclvalue(tkset[[ppp]]) <- R.to.Tcl(Rtkset[[ppp]][-out]) tkconfigure(remove.but[[ppp]], state = "disabled") tkselection.clear(listbox[[ppp]], "0", "end") }) for (i in 1:nsets) { add.but[[i]] <- tkbutton(setframe[[i]], text = "Add", fg = "darkgreen", disabledforeground = "darkgrey", width = 10, state = "disabled", command = eval(parse(text = gsub("ppp", as.character(i), add.cmd)))) remove.but[[i]] <- tkbutton(setframe[[i]], text = "Remove", fg = "darkred", disabledforeground = "darkgrey", width = 10, state = "disabled", command = eval(parse(text = gsub("ppp", as.character(i), remove.cmd)))) labelentry[[i]] <- tkentry(labelbox[[i]], textvariable = as.character(TCLlabel[[i]]), font = labelFont, bg = "white") if (edit.setlabels) { tkpack(setlabeltext[[i]], labelentry[[i]], side = "top", anchor = "w") } tkpack(label[[i]], add.but[[i]], remove.but[[i]], listbox[[i]], labelbox[[i]], side = "top", padx = 5, pady = 5) tkpack(setframe[[i]], side = "left", padx = 3, pady = 10) } fun1 <- deparse(function() { if (tclvalue(tkcurselection(listbox[[ppp]])) != "") { for (j in 1:nsets) { tkconfigure(add.but[[j]], state = "disabled") } tkconfigure(remove.but[[ppp]], state = "normal") } for (j in (1:nsets)[-ppp]) { tkconfigure(remove.but[[j]], state = "disabled") } tkfocus(listbox[[ppp]]) }) for (i in 1:nsets) { tkbind(listbox[[i]], "<>", eval(parse(text = gsub("ppp", as.character(i), fun1)))) } tkbind(items, "<>", function() { items.selected <- vec.to.pickfrom[1 + string.to.vector(tclvalue(tkcurselection(items)))] for (i in 1:nsets) { set[[i]] <- Tcl.to.R(tclvalue(tkset[[i]])) if (setequal(items.selected, intersect(items.selected, set[[i]]))) { tkconfigure(add.but[[i]], state = "disabled") } else tkconfigure(add.but[[i]], state = "normal") tkconfigure(remove.but[[i]], state = "disabled") } }) tkbind(items, "", function() tkfocus(items)) buttons.frame <- tkframe(right.frm) OK <- tclVar(0) ok.but <- tkbutton(buttons.frame, text = "OK", width = 10, command = function() { tkdestroy(base) tclvalue(OK) <- 1 }) tkconfigure(ok.but, state = "normal") cancel.but <- tkbutton(buttons.frame, text = "Cancel", width = 10, command = function() { tkdestroy(base) }) tkpack(ok.but, cancel.but, side = "left", padx = 20, pady = 20) tkpack(sets.frm, buttons.frame, side = "top") tkpack(left.frm, side = "left", anchor = "nw", padx = 1) tkpack(right.frm, anchor = "ne") tkwait.window(base) .Tcl("update idletasks") if (tclvalue(OK) == "1") { sets <- lapply(tkset, function(set) { match(Tcl.to.R(tclvalue(set)), vec.to.pickfrom) }) if (any(sapply(sets, length) == 0)) { warning(warningText) } labels <- lapply(TCLlabel, tclvalue) names(sets) <- labels result <- sets } else return(NULL) } else { result <- list() cat("**", title, "**\n\n") cat(items.label, "\n") op <- paste(format(seq_len(ni)), ": ", vec.to.pickfrom, sep = "") if (ni > 10) { fop <- format(op) nw <- nchar(fop[1], "w") + 2 ncol <- getOption("width")%/%nw if (ncol > 1) op <- paste(fop, c(rep(" ", ncol - 1), "\n"), sep = "", collapse = "") cat("", op, sep = "\n") } else cat("", op, "", sep = "\n") cat("Enter sequences of numbers separated by commas:\n") for (i in 1:nsets) { ind <- readline(paste(ifelse(nchar(setlabels[[i]]), setlabels[[i]], paste("Set", i)), ": ", sep = "")) ind <- eval(parse(text = paste("c(", ind, ")"))) if (edit.setlabels){ tmp <- readline(paste(labels.prompt, ifelse(nchar(setlabels[i]), paste(" [", setlabels[i], "]", sep = ""), ""), ": ", sep = "")) if (nchar(tmp)) setlabels[i] <- tmp } if (all(invalid <- !ind %in% seq(ni))) result[[i]] <- numeric(0) else if (any(invalid)){ warning("Ignored invalid selection(s): ", paste(ind[invalid], sep = ", "), ".\n", immediate. = TRUE) result[[i]] <- ind[!invalid] } else result[[i]] <- ind if (!preserve.order) result[[i]] <- sort(result[[i]]) } if (!all(sapply(result, length))) warning(warningText) names(result) <- setlabels } return( if (return.indices) lapply(result, function(set) subset[set]) else lapply(result, function(set) (vec[subset])[set]) ) } relimp/R/relimp.R0000644000175100001440000002625011646766322013416 0ustar hornikusers"print.relimp" <- function (x, digits = 3, ...) { object <- x sets <- object$sets labels <- names(sets) l1 <- length(sets[[1]]) l2 <- length(sets[[2]]) if (l1 > l2) { sets[[2]] <- c(sets[[2]], rep("", l1 - l2)) } if (l2 > l1) { sets[[1]] <- c(sets[[1]], rep("", l2 - l1)) } sets <- as.data.frame(sets) response.cat <- object$response.category names(sets) <- c(paste(" Numerator effects (\"", labels[1], "\")", sep = ""), paste(" Denominator effects (\"", labels[2], "\")", sep = "")) zz <- capture.output(print(sets, rowlab = rep("", nrow(sets)))) CI95 <- object$log.ratio + 1.96 * (object$se.log.ratio) * c(-1, 1) cat(paste("\n", "Relative importance summary for model\n", " ", paste(deparse(object$model), collapse = "\n"), "\n", if (!is.null(response.cat)) { paste("response category", response.cat, "\n\n") }, if (!is.null(object$dispersion)) paste("with dispersion set to", object$dispersion, "\n\n") else "\n", paste(zz, "", collapse = "\n"), "\n\n", "Ratio of effect standard deviations: ", round(exp(object$log.ratio), digits), "\n", "Log(sd ratio): ", round(object$log.ratio, digits), " (se ", round(object$se.log.ratio, digits), ")\n\n", "Approximate 95% confidence interval for log(sd ratio): (", paste(round(CI95, digits), collapse = ","), ")\n", "Approximate 95% confidence interval for sd ratio: (", paste(round(exp(CI95), digits), collapse = ","), ")\n", sep = "") ) } "relimp" <- function (object, set1 = NULL, set2 = NULL, label1 = "set1", label2 = "set2", subset = TRUE, response.cat = NULL, ...) { if (inherits(object, "multinom")) { require(nnet) } if (inherits(object, "multinom") && is.null(response.cat)) stop("argument `response.cat' must be specified") if (!is.null(response.cat)) response.cat <- as.character(response.cat) ## numbers get coerced if (inherits(object, "multinom") && !(response.cat %in% rownames(coef(object)))) stop("argument `response.cat' not valid for this model") covmat <- vcov(object, ...) if (is.null(set1) || is.null(set2)) { coefnames <- { if (!inherits(object, "multinom")) colnames(covmat) else colnames(coef(object)) } if (is.null(coefnames)) coefnames <- names(coef(object)) sets <- pickFrom(coefnames, nsets = 2, return.indices = FALSE, setlabels = c(label1, label2), title = "Specify a relative importance (\"relimp\") comparison", items.label = "Model coefficients") if (!is.null(sets)) { set1 <- sets[[1]] set2 <- sets[[2]] label1 <- names(sets)[1] label2 <- names(sets)[2] } else stop("\neffects for comparison (set1,set2) not specified") } else { if (max(union(set1, set2)) > length(coef(object))) { stop("Index out of bounds") } if (any(is.na(coef(object)[set1]))){ stop("set1 contains NAs")} if (any(is.na(coef(object)[set2]))){ stop("set2 contains NAs")} coefnames <- if (!inherits(object, "multinom")) names(coef(object)) else colnames(coef(object)) if (is.null(coefnames)) coefnames <- names(coef(object)) set1 <- coefnames[set1] set2 <- coefnames[set2]} ## notation below follows Silber, Rosenbaum and Ross (1995, JASA) coefs <- { if (!inherits(object, "multinom")) coef(object) else coef(object)[response.cat, ] } if (inherits(object, "multinom")) { indices <- t(matrix(1:prod(dim(coef(object))), nrow = ncol(coef(object)), ncol = nrow(coef(object)), dimnames = dimnames(t(coef(object))))) indices <- indices[response.cat, ] covmat <- covmat[indices, indices] } beta <- coefs[set1, drop = FALSE] gamma <- coefs[set2, drop = FALSE] if (!is.matrix(object$x)) modelmatrix <- model.matrix(object) else modelmatrix <- object$x if (is.numeric(subset) || (is.logical(subset) && (length(subset) == 1 || length(subset) == nrow(modelmatrix)))) { X <- modelmatrix[subset, set1, drop = FALSE] H <- modelmatrix[subset, set2, drop = FALSE] } else stop( paste("\nspecified subset should be either a vector of numeric indices,", "\nor a logical vector with length equal to the number of rows", "\nin the model frame for model", paste("\"", deparse(match.call()$object), "\"", sep = ""))) X <- sweep(X, 2, apply(X, 2, mean)) H <- sweep(H, 2, apply(H, 2, mean)) indices <- if (inherits(object, "multinom")){ c(paste(response.cat, set1, sep=":"), paste(response.cat, set2, sep=":"))} else c(set1, set2) Sigma <- covmat[indices, indices] pi <- X %*% beta phi <- H %*% gamma sd.ratio <- sd(as.vector(pi))/sd(as.vector(phi)) log.ratio <- log(sd.ratio) w <- rbind((t(X) %*% pi)/sum(pi * pi), (-t(H) %*% phi)/sum(phi * phi)) var.log.ratio <- t(w) %*% Sigma %*% w se.log.ratio <- sqrt(var.log.ratio) Call <- match.call() ## to see if the dispersion parameter was given dispersion <- { if (pmatch("disp", names(Call), 0) > 0) Call$dispersion else NULL } ans <- list(model = object$call, response.category = response.cat, dispersion = dispersion, sets = list(set1, set2), log.ratio = log.ratio, se.log.ratio = se.log.ratio) names(ans$sets) <- c(label1, label2) class(ans) <- "relimp" return(ans) } "relrelimp" <- function (object, set1 = NULL, set2 = NULL, label1 = "set1", label2 = "set2", subset = TRUE, response.cat1 = NULL, response.cat2 = NULL) { if (!inherits(object, "multinom")) stop("Object is not of class \"multinom\"") require(nnet) if (is.null(response.cat1) || is.null(response.cat2)) stop("arguments `response.cat1' and `response.cat2' must be specified") response.cat1 <- as.character(response.cat1) ## numbers get coerced response.cat2 <- as.character(response.cat2) if (!(response.cat1 %in% rownames(coef(object))) || !(response.cat2 %in% rownames(coef(object)))) stop("`response.cat' argument(s) not valid for this model") if (is.null(set1) || is.null(set2)) { coefnames <- { if (!inherits(object, "multinom")) names(coef(object)) else colnames(coef(object)) } sets <- pickFrom(coefnames, nsets = 2, return.indices = TRUE, setlabels = c(label1, label2), title = "Specify a relative importance (\"relimp\") comparison", items.label = "Model coefficients") if (!is.null(sets)) { set1 <- sets[[1]] set2 <- sets[[2]] label1 <- names(sets)[1] label2 <- names(sets)[2] } else stop("\neffects for comparison (set1,set2) not specified") } if (max(union(set1, set2)) > length(coef(object))) { stop("Index out of bounds") } ## notation below follows Silber, Rosenbaum and Ross (1995, JASA) coefs <- coef(object)[c(response.cat1, response.cat2), ] covmat <- vcov(object) indices <- t(matrix(1:prod(dim(coef(object))), nrow = ncol(coef(object)), ncol = nrow(coef(object)), dimnames = dimnames(t(coef(object))))) indices <- as.vector(t(indices[c(response.cat1, response.cat2), ])) covmat <- covmat[indices, indices] beta1 <- as.vector(coefs[1, set1, drop = FALSE]) gamma1 <- as.vector(coefs[1, set2, drop = FALSE]) beta2 <- as.vector(coefs[2, set1, drop = FALSE]) gamma2 <- as.vector(coefs[2, set2, drop = FALSE]) names <- colnames(coefs) names1 <- names[set1] names2 <- names[set2] if (!is.matrix(object$x)) modelmatrix <- model.matrix(object) else modelmatrix <- object$x if (is.numeric(subset) || (is.logical(subset) && (length(subset) == 1 || length(subset) == nrow(modelmatrix)))) { X <- modelmatrix[subset, set1, drop = FALSE] H <- modelmatrix[subset, set2, drop = FALSE] } else stop( paste("\nspecified subset should be either a vector of numeric indices,", "\nor a logical vector with length equal to the number of rows", "\nin the model frame for model", paste("\"", deparse(match.call()$object), "\"", sep = ""))) X <- sweep(X, 2, apply(X, 2, mean)) H <- sweep(H, 2, apply(H, 2, mean)) set1a <- set1 + ncol(coefs) set2a <- set2 + ncol(coefs) Sigma <- covmat[c(set1, set2, set1a, set2a), c(set1, set2, set1a, set2a)] Sigma1 <- covmat[c(set1, set2), c(set1, set2)] Sigma2 <- covmat[c(set1a, set2a), c(set1a, set2a)] pi1 <- X %*% beta1 phi1 <- H %*% gamma1 pi2 <- X %*% beta2 phi2 <- H %*% gamma2 sd.ratio1 <- sd(as.vector(pi1))/sd(as.vector(phi1)) sd.ratio2 <- sd(as.vector(pi2))/sd(as.vector(phi2)) log.ratio1 <- log(sd.ratio1) log.ratio2 <- log(sd.ratio2) log.ratioratio <- log.ratio1 - log.ratio2 w1 <- rbind((t(X) %*% pi1)/sum(pi1 * pi1), (-t(H) %*% phi1)/sum(phi1 * phi1)) var.log.ratio1 <- t(w1) %*% Sigma1 %*% w1 se.log.ratio1 <- sqrt(var.log.ratio1) w2 <- rbind((t(X) %*% pi2)/sum(pi2 * pi2), (-t(H) %*% phi2)/sum(phi2 * phi2)) var.log.ratio2 <- t(w2) %*% Sigma2 %*% w2 se.log.ratio2 <- sqrt(var.log.ratio2) w <- rbind((t(X) %*% pi1)/sum(pi1 * pi1), (-t(H) %*% phi1)/sum(phi1 * phi1), (-t(X) %*% pi2)/sum(pi2 * pi2), (t(H) %*% phi2)/sum(phi2 * phi2)) var.log.ratioratio <- t(w) %*% Sigma %*% w se.log.ratioratio <- sqrt(var.log.ratioratio) Call <- match.call() ## to see if the dispersion parameter was given dispersion <- { if (pmatch("disp", names(Call), 0) > 0) Call$dispersion else NULL } ans <- list(model = object$call, response.category = c(response.cat1, response.cat2), dispersion = dispersion, sets = list(names1, names2), log.ratio = c(log.ratio1, log.ratio2, log.ratioratio), se.log.ratio = c(se.log.ratio1, se.log.ratio2, se.log.ratioratio) ) names(ans$sets) <- c(label1, label2) class(ans) <- "relrelimp" return(ans) } relimp/DESCRIPTION0000644000175100001440000000116211647073434013277 0ustar hornikusersPackage: relimp Version: 1.0-3 Title: Relative Contribution of Effects in a Regression Model Author: David Firth with contributions from Heather Turner Maintainer: David Firth URL: http://go.warwick.ac.uk/relimp, http://go.warwick.ac.uk/dfirth Description: Functions to facilitate inference on the relative importance of predictors in a linear or generalized linear model, and a couple of useful Tcl/Tk widgets. Depends: R (>= 2.0.0) Imports: tcltk Suggests: nnet, MASS License: GPL (>= 2) Packaged: 2011-10-17 08:58:24 UTC; david Repository: CRAN Date/Publication: 2011-10-17 18:42:36 relimp/NAMESPACE0000644000175100001440000000015211021453422012767 0ustar hornikusersexport(showData, pickFrom, relimp, relrelimp, R.to.Tcl, Tcl.to.R) import(tcltk) S3method(print, relimp) relimp/MD50000644000175100001440000000102011647073434012072 0ustar hornikusers1d5dbab8c9f9cd49fb2898d58ef5fa5b *DESCRIPTION 845582ecbd46ab8de02eeccbe4cba2d6 *NAMESPACE 9942c5121b317407fb29b2399b96f23a *R/pickFrom.R 83c1ef5cf531699ae0fe153703c77052 *R/relimp.R dcff866f49915f00cf7a60e42baeee2c *R/showData.R 7ab24c6803bf57c360d1755ebc260d21 *man/R.to.Tcl.Rd c9eebd9817aa8eb54b7297bdb5a1faa1 *man/Tcl.to.R.Rd a6bebcddcb116115c545b9ee4e912043 *man/pickFrom.Rd f994aea76a6bae7baf5b1aa6efdf0fab *man/relimp.Rd bcd560d8d146dd1cc001e5f456555d4c *man/relrelimp.Rd 40683a75060fa8c8bb6d702683825fbc *man/showData.Rd