relimp/0000755000175100001440000000000012677016162011570 5ustar hornikusersrelimp/NAMESPACE0000644000175100001440000000030212673343456013007 0ustar hornikusersimportFrom("stats", "coef", "model.matrix", "sd", "vcov") importFrom("utils", "capture.output") export(showData, pickFrom, relimp, relrelimp, R.to.Tcl, Tcl.to.R) S3method(print, relimp) relimp/R/0000755000175100001440000000000012463673674012003 5ustar hornikusersrelimp/R/pickFrom.R0000644000175100001440000003416212463666234013700 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")) { 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.R0000644000175100001440000000076012463673674014664 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]] } relimp/R/showData.R0000644000175100001440000002747512673346712013710 0ustar hornikusersshowData <- 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) { 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) }) { 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) { 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) { 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) { 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) { 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) { 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") } 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) onClose <- function(){ if ("Rcmdr" %in% loadedNamespaces()){ open.showData.windows <- Rcmdr::getRcmdr("open.showData.windows", fail=FALSE) if (!is.null(open.showData.windows)){ open.showData.windows[[object.name]] <- NULL Rcmdr::putRcmdr("open.showData.windows", open.showData.windows) } } tcltk::tkdestroy(base) } tcltk::tkwm.protocol(base, "WM_DELETE_WINDOW", onClose) invisible(base) } relimp/R/relimp.R0000644000175100001440000002655612463655146013426 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")) { 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/MD50000644000175100001440000000110412677016162012074 0ustar hornikusers1bed3226bc5b0ffb918eff8d471bf6c3 *DESCRIPTION 034208a478f7b420dad36741da01a564 *NAMESPACE 807140244debf9cde189b0b03b02b28f *R/Tcl-utilities.R b1e7cefb88d43a0427875b40d693ab7f *R/pickFrom.R 940147f3ddfa593bc0e2975bba1fbd2b *R/relimp.R d6c18652882390641dd744d243a15cb9 *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 87d46f060b1d90ce16049e01213f4011 *man/showData.Rd relimp/DESCRIPTION0000644000175100001440000000120712677016162013276 0ustar hornikusersPackage: relimp Version: 1.0-5 Date: 2016-03-19 Title: Relative Contribution of Effects in a Regression Model Author: David Firth with contributions from Heather Turner and John Fox 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, Rcmdr Imports: stats, utils License: GPL (>= 2) NeedsCompilation: no Packaged: 2016-03-30 13:27:22 UTC; david Repository: CRAN Date/Publication: 2016-03-30 20:35:30 relimp/man/0000755000175100001440000000000012676751404012347 5ustar hornikusersrelimp/man/Tcl.to.R.Rd0000644000175100001440000000065512463613220014172 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.Rd0000644000175100001440000000721512463613220014400 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/man/relrelimp.Rd0000644000175100001440000000735312463613220014624 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.Rd0000644000175100001440000000552012675212153014402 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{ Invisibly returns the Tk window containing the displayed data frame. } \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}; with Rcmdr-specific features contributed by John Fox} \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.Rd0000644000175100001440000000067712463613220014176 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/relimp.Rd0000644000175100001440000001115012463673240014117 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{ 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}