relimp/0000755000176000001440000000000012464175253011603 5ustar ripleyusersrelimp/NAMESPACE0000644000176000001440000000013312463660477013025 0ustar ripleyusersexport(showData, pickFrom, relimp, relrelimp, R.to.Tcl, Tcl.to.R) S3method(print, relimp) relimp/R/0000755000176000001440000000000012463727773012015 5ustar ripleyusersrelimp/R/pickFrom.R0000644000176000001440000003416212463722334013704 0ustar ripleyusers"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")) { requireNamespace("tcltk", quietly = TRUE) 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 <- tcltk::tktoplevel(takefocus = 1) tcltk::tkwm.title(base, title) tcltk::tkwm.geometry(base, windowPos) tcltk::tkwm.resizable(base, 0, 0) right.frm <- tcltk::tkframe(base) left.frm <- tcltk::tkframe(base) items.list <- as.character(tcltk::tclVar(paste("{", paste(vec.to.pickfrom, collapse = "} {"), "}", sep = ""))) items.frm <- tcltk::tkframe(left.frm) items.label <- tcltk::tklabel(items.frm, text = items.label, anchor = "w", justify = "left") tcltk::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 <- tcltk::tklistbox(items.frm, listvar = items.list, bg = "grey50", selectmode = "extended", fg = "white", font = listFont, width = items.width, height = items.height) tcltk::tkgrid(items, row = 1, column = 0) preserve.order <- tcltk::tclVar(as.numeric(preserve.order)) buttons.frm <- tcltk::tkframe(left.frm) buttonA <- tcltk::tkradiobutton(buttons.frm, text = "Sort sets in\nthe above order\nupon \"Add\"", justify = "left", variable = preserve.order, value = "1", command = function(){NULL} ) buttonB <- tcltk::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 <- tcltk::tkscrollbar(items.frm, orient = "vertical", repeatinterval = 1, command = function(...) { tcltk::tkyview(items, ...) }) tcltk::tkconfigure(items, yscrollcommand = function(...) { tcltk::tkset(items.scrollbar, ...) xy <- string.to.vector(tcltk::tclvalue(tcltk::tkget(items.scrollbar))) tcltk::tkyview.moveto(items, xy[1]) }) tcltk::tkgrid(items.scrollbar, row = 1, column = 1, sticky = "ns") } tcltk::tkpack(buttonA, buttonB, pady = 1, padx = 5, side = "top", anchor = "nw") tcltk::tkpack(items.frm, buttons.frm, pady = 1, padx = 5, side = "top") tcltk::tkpack(left.frm, side = "top", expand = "true", anchor = "n") sets.frm <- tcltk::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]] <- tcltk::tclVar("") TCLlabel[[i]] <- tcltk::tclVar(setlabels[[i]]) setframe[[i]] <- tcltk::tkframe(sets.frm, width = 250, relief = "groove", borderwidth = 2) label[[i]] <- tcltk::tklabel(setframe[[i]], text = setlabels[[i]]) listvarname[[i]] <- as.character(tkset[[i]]) listbox[[i]] <- tcltk::tklistbox(setframe[[i]], listvar = listvarname[[i]], bg = "white", height = subset.height, font = listFont, width = items.width, selectmode = "extended") labelbox[[i]] <- tcltk::tkframe(setframe[[i]], width = 250) setlabeltext[[i]] <- tcltk::tklabel(labelbox[[i]], text = paste(labels.prompt, ":", sep = "")) } add.cmd <- deparse(function() { set[[ppp]] <- match(Tcl.to.R(tcltk::tclvalue(tkset[[ppp]])), vec.to.pickfrom) set[[ppp]] <- union(set[[ppp]], 1 + string.to.vector(tcltk::tclvalue(tcltk::tkcurselection(items)))) if (as.logical(tcltk::tclObj(preserve.order))) set[[ppp]] <- sort(set[[ppp]]) tcltk::tclvalue(tkset[[ppp]]) <- R.to.Tcl(vec.to.pickfrom[set[[ppp]]]) tcltk::tkconfigure(add.but[[ppp]], state = "disabled") }) remove.cmd <- deparse(function() { Rtkset[[ppp]] <- Tcl.to.R(tcltk::tclvalue(tkset[[ppp]])) out <- 1 + string.to.vector(tcltk::tclvalue(tcltk::tkcurselection(listbox[[ppp]]))) if (length(Rtkset[[ppp]]) == length(out)) tcltk::tclvalue(tkset[[ppp]]) <- "" else tcltk::tclvalue(tkset[[ppp]]) <- R.to.Tcl(Rtkset[[ppp]][-out]) tcltk::tkconfigure(remove.but[[ppp]], state = "disabled") tcltk::tkselection.clear(listbox[[ppp]], "0", "end") }) for (i in 1:nsets) { add.but[[i]] <- tcltk::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]] <- tcltk::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]] <- tcltk::tkentry(labelbox[[i]], textvariable = as.character(TCLlabel[[i]]), font = labelFont, bg = "white") if (edit.setlabels) { tcltk::tkpack(setlabeltext[[i]], labelentry[[i]], side = "top", anchor = "w") } tcltk::tkpack(label[[i]], add.but[[i]], remove.but[[i]], listbox[[i]], labelbox[[i]], side = "top", padx = 5, pady = 5) tcltk::tkpack(setframe[[i]], side = "left", padx = 3, pady = 10) } fun1 <- deparse(function() { if (tcltk::tclvalue(tcltk::tkcurselection(listbox[[ppp]])) != "") { for (j in 1:nsets) { tcltk::tkconfigure(add.but[[j]], state = "disabled") } tcltk::tkconfigure(remove.but[[ppp]], state = "normal") } for (j in (1:nsets)[-ppp]) { tcltk::tkconfigure(remove.but[[j]], state = "disabled") } tcltk::tkfocus(listbox[[ppp]]) }) for (i in 1:nsets) { tcltk::tkbind(listbox[[i]], "<>", eval(parse(text = gsub("ppp", as.character(i), fun1)))) } tcltk::tkbind(items, "<>", function() { items.selected <- vec.to.pickfrom[1 + string.to.vector(tcltk::tclvalue(tcltk::tkcurselection(items)))] for (i in 1:nsets) { set[[i]] <- Tcl.to.R(tcltk::tclvalue(tkset[[i]])) if (setequal(items.selected, intersect(items.selected, set[[i]]))) { tcltk::tkconfigure(add.but[[i]], state = "disabled") } else tcltk::tkconfigure(add.but[[i]], state = "normal") tcltk::tkconfigure(remove.but[[i]], state = "disabled") } }) tcltk::tkbind(items, "", function() tcltk::tkfocus(items)) buttons.frame <- tcltk::tkframe(right.frm) OK <- tcltk::tclVar(0) ok.but <- tcltk::tkbutton(buttons.frame, text = "OK", width = 10, command = function() { tcltk::tkdestroy(base) tcltk::tclvalue(OK) <- 1 }) tcltk::tkconfigure(ok.but, state = "normal") cancel.but <- tcltk::tkbutton(buttons.frame, text = "Cancel", width = 10, command = function() { tcltk::tkdestroy(base) }) tcltk::tkpack(ok.but, cancel.but, side = "left", padx = 20, pady = 20) tcltk::tkpack(sets.frm, buttons.frame, side = "top") tcltk::tkpack(left.frm, side = "left", anchor = "nw", padx = 1) tcltk::tkpack(right.frm, anchor = "ne") tcltk::tkwait.window(base) tcltk::.Tcl("update idletasks") if (tcltk::tclvalue(OK) == "1") { sets <- lapply(tkset, function(set) { match(Tcl.to.R(tcltk::tclvalue(set)), vec.to.pickfrom) }) if (any(sapply(sets, length) == 0)) { warning(warningText) } labels <- lapply(TCLlabel, tcltk::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/Tcl-utilities.R0000644000176000001440000000076012463727773014676 0ustar ripleyusersR.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]] } relimp/R/showData.R0000644000176000001440000003173012463725475013713 0ustar ripleyusersR.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)") } if (!capabilities("tcltk")) stop("tcltk capability missing") requireNamespace("tcltk", quietly = TRUE) 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 <- tcltk::tktoplevel() tcltk::tkwm.geometry(base, placement) tcltk::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 <- tcltk::tktext(base, bg = colname.bgcolor, fg = colname.textcolor, font = font, height = 1, width = winwidth, takefocus = TRUE) ftr <- tcltk::tktext(base, bg = colname.bgcolor, fg = colname.textcolor, font = font, height = 1, width = winwidth, takefocus = TRUE) textheight <- min(maxheight, nrows) txt <- tcltk::tktext(base, bg = body.bgcolor, fg = body.textcolor, font = font, height = textheight, width = winwidth, setgrid = 1, takefocus = TRUE) lnames <- tcltk::tktext(base, bg = rowname.bgcolor, fg = rowname.textcolor, font = font, height = textheight, width = namewidth, takefocus = TRUE) rnames <- tcltk::tktext(base, bg = rowname.bgcolor, fg = rowname.textcolor, font = font, height = textheight, width = namewidth, takefocus = TRUE) xscroll <- tcltk::tkscrollbar(base, orient = "horizontal", repeatinterval = 1, command = function(...) { tcltk::tkxview(txt, ...) tcltk::tkxview(hdr, ...) tcltk::tkxview(ftr, ...) }) string.to.vector <- function(string.of.indices) { string.of.indices <- tcltk::tclvalue(string.of.indices) as.numeric(strsplit(string.of.indices, split = " ")[[1]]) } tcltk::tkconfigure(txt, xscrollcommand = function(...) { tcltk::tkset(xscroll, ...) xy <- string.to.vector(tcltk::tkget(xscroll)) tcltk::tkxview.moveto(hdr, xy[1]) tcltk::tkxview.moveto(ftr, xy[1]) }) tcltk::tkconfigure(hdr, xscrollcommand = function(...) { tcltk::tkset(xscroll, ...) xy <- string.to.vector(tcltk::tkget(xscroll)) tcltk::tkxview.moveto(txt, xy[1]) tcltk::tkxview.moveto(ftr, xy[1]) }) tcltk::tkconfigure(ftr, xscrollcommand = function(...) { tcltk::tkset(xscroll, ...) xy <- string.to.vector(tcltk::tkget(xscroll)) tcltk::tkxview.moveto(hdr, xy[1]) tcltk::tkxview.moveto(txt, xy[1]) }) yscroll <- tcltk::tkscrollbar(base, orient = "vertical", repeatinterval = 1, command = function(...) { tcltk::tkyview(txt, ...) tcltk::tkyview(lnames, ...) tcltk::tkyview(rnames, ...) }) tcltk::tkconfigure(txt, yscrollcommand = function(...) { tcltk::tkset(yscroll, ...) xy <- string.to.vector(tcltk::tkget(yscroll)) tcltk::tkyview.moveto(lnames, xy[1]) tcltk::tkyview.moveto(rnames, xy[1]) }) tcltk::tkconfigure(lnames, yscrollcommand = function(...) { tcltk::tkset(yscroll, ...) xy <- string.to.vector(tcltk::tkget(yscroll)) tcltk::tkyview.moveto(txt, xy[1]) tcltk::tkyview.moveto(rnames, xy[1]) }) tcltk::tkconfigure(rnames, yscrollcommand = function(...) { tcltk::tkset(yscroll, ...) xy <- string.to.vector(tcltk::tkget(yscroll)) tcltk::tkyview.moveto(txt, xy[1]) tcltk::tkyview.moveto(lnames, xy[1]) }) tcltk::tkbind(txt, "", function(x, y) { tcltk::tkscan.dragto(txt, x, y) }) ## The next block just enables copying from the text boxes { copyText.hdr <- function(){ tcltk::tcl("event", "generate", tcltk::.Tk.ID(hdr), "<>")} tcltk::tkbind(hdr, "", function() tcltk::tkfocus(hdr)) editPopupMenu.hdr <- tcltk::tkmenu(hdr, tearoff = FALSE) tcltk::tkadd(editPopupMenu.hdr, "command", label = "Copy ", command = copyText.hdr) RightClick.hdr <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tcltk::tkwinfo("rootx", hdr)) rooty <- as.integer(tcltk::tkwinfo("rooty", hdr)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcltk::tcl("tk_popup", editPopupMenu.hdr, xTxt, yTxt) } tcltk::tkbind(hdr, "", RightClick.hdr) tcltk::tkbind(hdr, "", copyText.hdr) ## copyText.ftr <- function(){ tcltk::tcl("event", "generate", tcltk::.Tk.ID(ftr), "<>")} tcltk::tkbind(ftr, "", function() tcltk::tkfocus(ftr)) editPopupMenu.ftr <- tcltk::tkmenu(ftr, tearoff = FALSE) tcltk::tkadd(editPopupMenu.ftr, "command", label = "Copy ", command = copyText.ftr) RightClick.ftr <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tcltk::tkwinfo("rootx", ftr)) rooty <- as.integer(tcltk::tkwinfo("rooty", ftr)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcltk::tcl("tk_popup", editPopupMenu.ftr, xTxt, yTxt) } tcltk::tkbind(ftr, "", RightClick.ftr) tcltk::tkbind(ftr, "", copyText.ftr) ## copyText.txt <- function(){ tcltk::tcl("event", "generate", tcltk::.Tk.ID(txt), "<>")} tcltk::tkbind(txt, "", function() tcltk::tkfocus(txt)) editPopupMenu.txt <- tcltk::tkmenu(txt, tearoff = FALSE) tcltk::tkadd(editPopupMenu.txt, "command", label = "Copy ", command = copyText.txt) RightClick.txt <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tcltk::tkwinfo("rootx", txt)) rooty <- as.integer(tcltk::tkwinfo("rooty", txt)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcltk::tcl("tk_popup", editPopupMenu.txt, xTxt, yTxt) } tcltk::tkbind(txt, "", RightClick.txt) tcltk::tkbind(txt, "", copyText.txt) ## copyText.lnames <- function(){ tcltk::tcl("event", "generate", tcltk::.Tk.ID(lnames), "<>")} tcltk::tkbind(lnames, "", function() tcltk::tkfocus(lnames)) editPopupMenu.lnames <- tcltk::tkmenu(lnames, tearoff = FALSE) tcltk::tkadd(editPopupMenu.lnames, "command", label = "Copy ", command = copyText.lnames) RightClick.lnames <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tcltk::tkwinfo("rootx", lnames)) rooty <- as.integer(tcltk::tkwinfo("rooty", lnames)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcltk::tcl("tk_popup", editPopupMenu.lnames, xTxt, yTxt) } tcltk::tkbind(lnames, "", RightClick.lnames) tcltk::tkbind(lnames, "", copyText.lnames) ## copyText.rnames <- function(){ tcltk::tcl("event", "generate", tcltk::.Tk.ID(rnames), "<>")} tcltk::tkbind(rnames, "", function() tcltk::tkfocus(rnames)) editPopupMenu.rnames <- tcltk::tkmenu(rnames, tearoff = FALSE) tcltk::tkadd(editPopupMenu.rnames, "command", label = "Copy ", command = copyText.rnames) RightClick.rnames <- function(x,y) # x and y are the mouse coordinates { rootx <- as.integer(tcltk::tkwinfo("rootx", rnames)) rooty <- as.integer(tcltk::tkwinfo("rooty", rnames)) xTxt <- as.integer(x) + rootx yTxt <- as.integer(y) + rooty tcltk::tcl("tk_popup", editPopupMenu.rnames, xTxt, yTxt) } tcltk::tkbind(rnames, "", RightClick.rnames) tcltk::tkbind(rnames, "", copyText.rnames) } tcltk::tktag.configure(hdr, "notwrapped", wrap = "none") tcltk::tktag.configure(ftr, "notwrapped", wrap = "none") tcltk::tktag.configure(txt, "notwrapped", wrap = "none") tcltk::tktag.configure(lnames, "notwrapped", wrap = "none") tcltk::tktag.configure(rnames, "notwrapped", wrap = "none") tcltk::tkinsert(txt, "end", paste(paste(yy[-1], collapse = "\n"), sep = ""), "notwrapped") tcltk::tkgrid(txt, row = 1, column = 1, sticky = "nsew") if ("top" %in% colname.bar) { tcltk::tkinsert(hdr, "end", paste(yy[1], sep = ""), "notwrapped") tcltk::tkgrid(hdr, row = 0, column = 1, sticky = "ew") } if ("bottom" %in% colname.bar) { tcltk::tkinsert(ftr, "end", paste(yy[1], sep = ""), "notwrapped") tcltk::tkgrid(ftr, row = 2, column = 1, sticky = "ew") } if ("left" %in% rowname.bar) { tcltk::tkinsert(lnames, "end", paste(rowname.text, collapse = "\n"), "notwrapped") tcltk::tkgrid(lnames, row = 1, column = 0, sticky = "ns") } if ("right" %in% rowname.bar) { tcltk::tkinsert(rnames, "end", paste(rowname.text, collapse = "\n"), "notwrapped") tcltk::tkgrid(rnames, row = 1, column = 2, sticky = "ns") } # tkconfigure(hdr, state = "disabled") # tkconfigure(ftr, state = "disabled") tcltk::tkconfigure(txt, state = "disabled") tcltk::tkconfigure(lnames, state = "disabled") tcltk::tkconfigure(rnames, state = "disabled") if (maxheight < nrows) { tcltk::tkgrid(yscroll, row = 1, column = 3, sticky = "ns") } if (maxwidth < datawidth) { tcltk::tkgrid(xscroll, row = 3, column = 1, sticky = "ew") } tcltk::tkgrid.rowconfigure(base, 1, weight = 1) tcltk::tkgrid.columnconfigure(base, 1, weight = 1) tcltk::tkwm.maxsize(base, 1 + datawidth, nrows) tcltk::tkwm.minsize(base, 1 + nchar(names(dataframe)[1]), 1) invisible(NULL) } relimp/R/relimp.R0000644000176000001440000002655612463711246013432 0ustar ripleyusers"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")) { if (requireNamespace("nnet", quietly = TRUE)) {} else {stop("the necessary \"nnet\" package is not available")} } 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")) { the.coefs <- coef(object) indices <- t(matrix(1:prod(dim(the.coefs)), nrow = ncol(the.coefs), ncol = nrow(the.coefs), dimnames = dimnames(t(the.coefs)))) 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\"") } if (requireNamespace("nnet", quietly = TRUE)) {} else {stop("the \"nnet\" package is not available")} 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) the.coefs <- coef(object) if (!(response.cat1 %in% rownames(the.coefs)) || !(response.cat2 %in% rownames(the.coefs))) 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(the.coefs) } 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(the.coefs)) { stop("Index out of bounds") } ## notation below follows Silber, Rosenbaum and Ross (1995, JASA) coefs <- the.coefs[c(response.cat1, response.cat2), ] covmat <- vcov(object) indices <- t(matrix(1:prod(dim(the.coefs)), nrow = ncol(the.coefs), ncol = nrow(the.coefs), dimnames = dimnames(t(the.coefs)))) 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/MD50000644000176000001440000000110412464175253012107 0ustar ripleyusers69265466fbcc07fcac5e1eafe5209284 *DESCRIPTION 87b504621da5940e0c07e8eeafe6b11a *NAMESPACE 807140244debf9cde189b0b03b02b28f *R/Tcl-utilities.R b1e7cefb88d43a0427875b40d693ab7f *R/pickFrom.R 940147f3ddfa593bc0e2975bba1fbd2b *R/relimp.R bfefdc253f0cf5221e28aef537d66ebd *R/showData.R 7ab24c6803bf57c360d1755ebc260d21 *man/R.to.Tcl.Rd c9eebd9817aa8eb54b7297bdb5a1faa1 *man/Tcl.to.R.Rd a6bebcddcb116115c545b9ee4e912043 *man/pickFrom.Rd dde26a378d65676ad1aa7f5af2d8ac4c *man/relimp.Rd bcd560d8d146dd1cc001e5f456555d4c *man/relrelimp.Rd 40683a75060fa8c8bb6d702683825fbc *man/showData.Rd relimp/DESCRIPTION0000644000176000001440000000113512464175253013311 0ustar ripleyusersPackage: relimp Version: 1.0-4 Date: 2015-02-02 Title: Relative Contribution of Effects in a Regression Model Author: David Firth with contributions from Heather Turner Maintainer: David Firth URL: http://warwick.ac.uk/relimp 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) Suggests: tcltk, nnet, MASS License: GPL (>= 2) Packaged: 2015-02-02 17:34:24 UTC; david NeedsCompilation: no Repository: CRAN Date/Publication: 2015-02-03 17:43:23 relimp/man/0000755000176000001440000000000012463727340012355 5ustar ripleyusersrelimp/man/Tcl.to.R.Rd0000644000176000001440000000065512463647317014222 0ustar ripleyusers\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.Rd0000644000176000001440000000721512463647317014430 0ustar ripleyusers\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/man/relrelimp.Rd0000644000176000001440000000735312463647317014654 0ustar ripleyusers\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.Rd0000644000176000001440000000535412463647317014432 0ustar ripleyusers\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/R.to.Tcl.Rd0000644000176000001440000000067712463647317014226 0ustar ripleyusers\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/relimp.Rd0000644000176000001440000001115012463727340014132 0ustar ripleyusers\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{ set.seed(182) ## an arbitrary number, just for reproducibility 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}