Nothing
# Small modification to several Rcmdr functions
## - numericToFactor --> add a check box for Make ordered factor
## - binVariable --> add an option to levels names: Range midpoints
## - reorderFactor --> Reorder level factor for several factors at a time and convert to ordered factor
## - NewDataSet --> Automatically save the file with the data set and load
## - variablesDataSet --> show also the variable type betwen brackets
numericToFactor2 <- function(){
# Author: J. Fox (Modified by M. A. Mosquera, 22 Oct 18)
initializeDialog(title=gettextRcmdr("Convert Numeric Variables to Factors"))
dataFrame <- tkframe(top)
variableBox <- variableListBox(dataFrame, Numeric(), selectmode="multiple",
title=gettextRcmdr("Variables (pick one or more)"))
radioButtons(dataFrame, name="levels", buttons=c("names", "numbers"),
labels=gettextRcmdr(c("Supply level names", "Use numbers")), title=gettextRcmdr("Factor Levels"))
orderedFrame <- tkframe(top)
orderedVariable <- tclVar("0")
orderedCheckBox <- ttkcheckbutton(orderedFrame, variable=orderedVariable)
factorNameFrame <- tkframe(top)
factorName <- tclVar(gettextRcmdr("<same as variables>"))
factorNameField <- ttkentry(factorNameFrame, width="20", textvariable=factorName)
onOK <- function(){
variables <- getSelection(variableBox)
closeDialog()
facname <- trim.blanks(tclvalue(factorName))
.activeDataSet <- ActiveDataSet()
cmd <- paste("apply(", .activeDataSet, "[c(", paste(
paste('"', variables, '"', sep=""),
collapse=","), ")], 2, function(x) sort(unique(x)))", sep="")
levs <- eval(parse(text=cmd), envir=.GlobalEnv)
sameLevels <- (length(variables) == 1) ||
((is.matrix(levs)) && (all(0 == apply(levs, 1, var))))
if (length(variables) == 0) {
errorCondition(recall=numericToFactor2, message=gettextRcmdr("You must select a variable."))}
else command <- paste(.activeDataSet, " <- within(", .activeDataSet, ", {", sep="")
for (name in variables){
fname <- if (facname == gettextRcmdr("<same as variables>")) name
else if (length(variables) == 1) facname
else paste(facname, name, sep="")
if (!is.valid.name(fname)){
errorCondition(recall=numericToFactor2,
message=paste('"', fname, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(fname, Variables())) {
if ("no" == tclvalue(checkReplace(fname))){
numericToFactor2()
return()
}
}
levelsType <- tclvalue(levelsVariable)
env <- environment()
if (((name == variables[1]) || (!sameLevels)) && (levelsType == "names")){
values <- sort(unique(eval(parse(text=paste(.activeDataSet, "$", name, sep="")),
envir=.GlobalEnv)))
nvalues <- length(values)
if (nvalues > 30) {
errorCondition(recall=numericToFactor2,
message=sprintf(gettextRcmdr("Number of levels (%d) too large."), nvalues))
return()
}
initializeDialog(subdialog,
title=paste(gettextRcmdr("Level Names for"),
if(sameLevels && length(variables) > 1) "Factors" else fname))
names <- rep("", nvalues)
onOKsub <- function() {
closeDialog(subdialog)
for (i in 1:nvalues){
names[i] <- eval(parse(text=paste("tclvalue(levelName", i, ")", sep="")))
}
if (length(unique(names)) != nvalues){
errorCondition(recall=numericToFactor2,
message=gettextRcmdr("Levels names are not unique."))
return()
}
if (any(names == "")){
errorCondition(recall=numericToFactor2,
message=gettextRcmdr("A level name is empty."))
return()
}
assign("labels", paste(paste("'", names, "'", sep=""), collapse=","),
envir=env)
}
subOKCancelHelp()
tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Numeric value")), labelRcmdr(subdialog, text=gettextRcmdr("Level name")), sticky="w")
for (i in 1:nvalues){
valVar <- paste("levelName", i, sep="")
assign(valVar, tclVar(""))
assign(paste("entry", i, sep=""), ttkentry(subdialog, width="20",
textvariable=get(valVar)))
tkgrid(labelRcmdr(subdialog, text=values[i]), get(paste("entry", i, sep="")), sticky="w")
}
tkgrid(subButtonsFrame, sticky="w", columnspan=2)
dialogSuffix(subdialog, focus=entry1, onOK=onOKsub, force.wait=TRUE)
}
ordered <- tclvalue(orderedVariable)
if (levelsType == "names"){
if (!exists("labels", mode="character")) return()
cmd <- paste("factor(", name,
", labels=c(", labels, ")",if(ordered==1) ",ordered=TRUE" else "",")", sep="")
command <- paste(command, "\n ", fname, " <- ", cmd, sep="")
}
else{
command <- paste(command, "\n ", fname, " <- as.",if(ordered==1) "ordered" else "factor","(", name, ")", sep="")
}
}
command <- paste(command, "\n})", sep="")
result <- doItAndPrint(command)
if (class(result)[1] != "try-error") activeDataSet(.activeDataSet, flushModel=FALSE, flushDialogMemory=FALSE)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="factor")
tkgrid(getFrame(variableBox), labelRcmdr(dataFrame, text=" "), levelsFrame, sticky="nw")
tkgrid(dataFrame, sticky="w")
tkgrid(labelRcmdr(factorNameFrame,
text=gettextRcmdr("New variable name or prefix for multiple variables: ")),
factorNameField, sticky="w")
tkgrid(factorNameFrame, sticky="w")
tkgrid(orderedCheckBox, labelRcmdr(orderedFrame, text=gettextRcmdr("Make ordered factor")), sticky="w")
tkgrid(orderedFrame, sticky="w")
tkgrid(buttonsFrame, sticky="ew", columnspan=2)
tkgrid.configure(numbersButton, sticky="w")
tkgrid.configure(namesButton, sticky="w")
dialogSuffix(preventGrabFocus=TRUE)
}
binVariable2 <- function () {
# Author: Dan Putler (revision by J. Fox, 2 Feb 05) (Modified by M. A. Mosquera, 22 Oct 18)
defaults <- list (initial.levels = "specify", initial.bins = "3", initial.varName = NULL,
initial.newVar = "variable", initial.method = "intervals")
dialog.values <- getDialog ("binVariable2", defaults)
env <- environment()
initializeDialog(title = gettextRcmdr("Bin a Numeric Variable"))
variableFrame <- tkframe(top)
variableBox <- variableListBox(variableFrame, Numeric(),
title = gettextRcmdr("Variable to bin (pick one)"),
initialSelection = varPosn (dialog.values$initial.varName, "numeric"))
newVariableFrame <- tkframe(variableFrame)
newVariableName <- tclVar(dialog.values$initial.newVar)
newVariable <- ttkentry(newVariableFrame, width = "18", textvariable = newVariableName)
binsFrame <- tkframe(top)
binsVariable <- tclVar(dialog.values$initial.bins)
slider <- tkscale(binsFrame, from = 2, to = 20, showvalue = TRUE,
variable = binsVariable, resolution = 1, orient = "horizontal")
optionsFrame <- tkframe(top)
radioButtons(optionsFrame, name = "levels", buttons = c("specify",
"numbers", "ranges", "midpoints"), labels = c(gettextRcmdr(c("Specify names","Numbers", "Ranges")),
gettext("Ranges midpoints",domain="R-RcmdrPlugin.TeachStat")),
title = gettextRcmdr("Level Names"),initialValue = dialog.values$initial.levels)
radioButtons(optionsFrame, name = "method", buttons = c("intervals",
"proportions", "natural"), labels = gettextRcmdr(c("Equal-width bins",
"Equal-count bins", "Natural breaks\n(from K-means clustering)")),
title = gettextRcmdr("Binning Method"),
initialValue = dialog.values$initial.method)
onOK <- function() {
levels <- tclvalue(levelsVariable)
bins <- as.numeric(tclvalue(binsVariable))
varName <- getSelection(variableBox)
closeDialog()
if (length(varName) == 0) {
errorCondition(recall = binVariable2, message = gettextRcmdr("You must select a variable."))
return()
}
newVar <- tclvalue(newVariableName)
if (is.element(newVar, Variables())) {
if ("no" == tclvalue(checkReplace(newVar))) {
binVariable2()
return()
}
}
if (!is.valid.name(newVar)) {
errorCondition(message = paste("\"", newVar, "\" ",
gettextRcmdr("is not a valid name."), sep = ""),
recall = binVariable2)
return()
}
method <- tclvalue(methodVariable)
putDialog ("binVariable2", list (initial.levels = levels, initial.bins = bins, initial.varName = varName,
initial.newVar = newVar, initial.method = method))
if (levels == "specify") {
initializeDialog(subdialog, title = gettextRcmdr("Bin Names"))
onOKsub <- function() {
closeDialog(subdialog)
level <- character(bins)
for (i in 1:bins) {
level[i] <- eval(parse(text = paste("tclvalue(levelName",
i, ")", sep = "")))
}
if (length(unique(level)) != length(level)) {
errorCondition(window = subdialog, message = gettextRcmdr("Level names must be unique."),
recall = onOK)
return()
}
assign("levelNames", level, envir = env)
}
subOKCancelHelp()
tkgrid(labelRcmdr(subdialog, text = gettextRcmdr("Bin"),
fg = getRcmdr("title.color"), font="RcmdrTitleFont"), labelRcmdr(subdialog, text = gettextRcmdr("Name"),
fg = getRcmdr("title.color"), font="RcmdrTitleFont"), sticky = "w")
for (i in 1:bins) {
valVar <- paste("levelName", i, sep = "")
assign(valVar, tclVar(i))
assign(paste("entry", i, sep = ""), ttkentry(subdialog,
width = "20", textvariable = get(valVar)))
tkgrid(labelRcmdr(subdialog, text = as.character(i)),
get(paste("entry", i, sep = "")), sticky = "w")
}
tkgrid(subButtonsFrame, sticky = "w", columnspan = 2)
dialogSuffix(subdialog, focus = entry1, bindReturn = FALSE, force.wait=TRUE)
}
labels <- if (levels == "numbers")
"FALSE"
else if (levels == "ranges" || levels=="midpoints")
"NULL"
else {
if (!exists("levelNames")) {
onCancel()
binVariable2()
return()
}
paste("c('", paste(levelNames, collapse = "','"),
"')", sep = "")
}
.activeDataSet <- ActiveDataSet()
command <- paste0(.activeDataSet, "$", newVar, " <- ",
"as.ordered(with(", .activeDataSet, ", binVariable(", varName, ", bins=",
bins, ", method=", "'", method, "', labels=", labels,
")))")
if (levels=="midpoints"){
command<-paste0(command,"\n","levels(",.activeDataSet, "$", newVar,")<-local({\n \t",
".le <- read.table(text=gsub(\"[^-.0-9]\", \" \", levels(",
.activeDataSet, "$", newVar,")))\n \t",
"if(is.factor(.le$V1)){\n \t\t",
"levels(.le$V1)[1] <- min(",.activeDataSet, "$", newVar,")\n\t\t",
".le$V1 <- as.numeric(levels(.le$V1)[.le$V1])\n \t",
"}\n \t",
"with(.le,(V1+V2)/2)\n","})\n",.activeDataSet, "$", newVar, " <- ",
"as.numeric(levels(",.activeDataSet, "$", newVar,"))[",.activeDataSet, "$", newVar,"]")
}
logger(command)
result <- justDoIt(command)
if (class(result)[1] != "try-error")
activeDataSet(.activeDataSet, flushModel = FALSE,
flushDialogMemory = FALSE)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject = "bin.var", reset = "binVariable2")
tkgrid(labelRcmdr(newVariableFrame, text = gettextRcmdr("New variable name"),
fg = getRcmdr("title.color"), font="RcmdrTitleFont"), sticky = "w")
tkgrid(newVariable, sticky = "w")
tkgrid(getFrame(variableBox), labelRcmdr(variableFrame, text = " "),
newVariableFrame, sticky = "nw")
tkgrid(variableFrame, sticky = "w")
tkgrid(labelRcmdr(binsFrame, text = gettextRcmdr("Number of bins:")),
slider, sticky = "s")
tkgrid(binsFrame, sticky = "w")
tkgrid(levelsFrame, labelRcmdr(optionsFrame, text = " "),
methodFrame, sticky = "nw")
tkgrid(optionsFrame, sticky = "w")
tkgrid(buttonsFrame, sticky = "w")
dialogSuffix()
}
reorderFactors <- function(){
# Author: J. Fox (Modified by M. A. Mosquera, 22 Oct 18)
initializeDialog(title=gettextRcmdr("Reorder Factor Levels"))
variableBox <- variableListBox(top, Factors(), selectmode="multiple",
title=gettext("Factor (pick one or more)",domain="R-RcmdrPlugin.TeachStat"))
orderedFrame <- tkframe(top)
orderedVariable <- tclVar("0")
orderedCheckBox <- ttkcheckbutton(orderedFrame, variable=orderedVariable)
factorName <- tclVar(gettextRcmdr("<same as original>"))
factorNameField <- ttkentry(top, width="20", textvariable=factorName)
onOK <- function(){
variables <- getSelection(variableBox)
closeDialog()
facname <- trim.blanks(tclvalue(factorName))
.activeDataSet <- ActiveDataSet()
cmd <- paste("apply(", .activeDataSet, "[c(", paste(
paste('"', variables, '"', sep=""),
collapse=","), ")], 2, function(x) sort(unique(x)))", sep="")
levs <- eval(parse(text=cmd), envir=.GlobalEnv)
sameLevels <- (length(variables) == 1) ||
((is.matrix(levs)) && (all(1 == apply(levs, 1, function(x) length(unique(x))))))
if (length(variables) == 0) {
errorCondition(recall=reorderFactors, message=gettextRcmdr("You must select a variable."))
return()
}
else command <- paste(.activeDataSet, " <- within(", .activeDataSet, ", {", sep="")
# name <- trim.blanks(tclvalue(factorName))
for (name in variables){
fname <- if (facname == gettextRcmdr("<same as original>")) name
else if (length(variables) == 1) facname
else paste(facname, name, sep="")
if (!is.valid.name(fname)){
errorCondition(recall=reorderFactors,
message=paste('"', fname, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(fname, Variables())) {
if ("no" == tclvalue(checkReplace(fname))){
reorderFactors()
return()
}
}
env <- environment()
if ((name == variables[1]) || (!sameLevels)){
old.levels <- eval(parse(text=paste("levels(", .activeDataSet, "$", name, ")",
sep="")), envir=.GlobalEnv)
nvalues <- length(old.levels)
if (nvalues > 30) {
errorCondition(recall=reorderFactors,
message=sprintf(gettextRcmdr("Number of levels (%d) too large."), nvalues))
return()
}
initializeDialog(subdialog, title=paste(gettext("Reorder Levels for",domain="R-RcmdrPlugin.TeachStat"),
if(sameLevels && length(variables) > 1) gettextRcmdr("Factors") else fname))
order <- 1:nvalues
onOKsub <- function() {
closeDialog(subdialog)
opt <- options(warn=-1)
for (i in 1:nvalues){
order[i] <- as.numeric(eval(parse(text=paste("tclvalue(levelOrder", i, ")", sep=""))))
}
options(opt)
if (any(sort(order) != 1:nvalues) || any(is.na(order))){
errorCondition(recall=reorderFactors,
message=paste(gettextRcmdr("Order of levels must include all integers from 1 to "), nvalues, sep=""))
return()
}
assign("levels",old.levels[order(order)],envir=env)
}
subOKCancelHelp()
tkgrid(labelRcmdr(subdialog, text=gettextRcmdr("Old Levels"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"),
labelRcmdr(subdialog, text=gettextRcmdr("New order"), fg=getRcmdr("title.color"), font="RcmdrTitleFont"), sticky="w")
for (i in 1:nvalues){
valVar <- paste("levelOrder", i, sep="")
assign(valVar, tclVar(i))
assign(paste("entry", i, sep=""), ttkentry(subdialog, width="2",
textvariable=get(valVar)))
tkgrid(labelRcmdr(subdialog, text=old.levels[i]), get(paste("entry", i, sep="")), sticky="w")
}
tkgrid(subButtonsFrame, sticky="w", columnspan=2)
dialogSuffix(subdialog, focus=entry1, onOK=onOKsub, force.wait=TRUE)
}
ordered <- tclvalue(orderedVariable)
ordered <- if (ordered == "1") ", ordered=TRUE" else ""
cmd <- paste("factor(", name,
", levels=c(", paste(paste("'", levels, "'", sep=""), collapse=","), ")",
ordered, ")", sep="")
command <- paste(command, "\n ", fname, " <- ", cmd, sep="")
}
command <- paste(command, "\n})", sep="")
result <- doItAndPrint(command)
if (class(result)[1] != "try-error") activeDataSet(.activeDataSet, flushModel=FALSE, flushDialogMemory=FALSE)
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="factor")
tkgrid(getFrame(variableBox), sticky="nw")
tkgrid(labelRcmdr(top, text=gettextRcmdr("New variable name or prefix for multiple variables: ")), sticky="w")
tkgrid(factorNameField, sticky="w")
tkgrid(orderedCheckBox, labelRcmdr(orderedFrame, text=gettextRcmdr("Make ordered factor")), sticky="w")
tkgrid(orderedFrame, sticky="w")
tkgrid(buttonsFrame, sticky="w")
dialogSuffix(preventGrabFocus=TRUE)
}
newDataSet2 <- function() {
# Author: J. Fox (Modified by M. A. Mosquera, 22 Oct 18)
initializeDialog(title=gettextRcmdr("New Data Set"))
dsname <- tclVar("Dataset")
entryDsname <- ttkentry(top, width="20", textvariable=dsname)
onOK <- function(){
dsnameValue <- trim.blanks(tclvalue(dsname))
if (dsnameValue == "") {
errorCondition(recall=newDataSet2,
message=gettextRcmdr("You must enter the name of a data set."))
return()
}
if (!is.valid.name(dsnameValue)) {
errorCondition(recall=newDataSet2,
message=paste('"', dsnameValue, '" ', gettextRcmdr("is not a valid name."), sep=""))
return()
}
if (is.element(dsnameValue, listDataSets())) {
if ("no" == tclvalue(checkReplace(dsnameValue, gettextRcmdr("Data set")))){
newDataSet2()
return()
}
}
closeDialog()
command <- paste("editDataset(dsname='", dsnameValue, "')", sep="")
result <- justDoIt(command)
if (class(result)[1] != "try-error"){
if (!getRcmdr("dataset.modified")) return()
.data <- try(get(dsnameValue, envir=.GlobalEnv), silent=TRUE)
if (nrow(.data) == 0){
errorCondition(recall=newDataSet2, message=gettextRcmdr("empty data set."))
return()
}
# Automatically save
# wdir <- getwd()
# savefile <- paste(wdir, "/", dsnameValue,".RData", sep="")
# Ask for a name to save
savefile <- tclvalue(tkgetSaveFile(filetypes=
gettextRcmdr('{"All Files" {"*"}} {"R Data Files" {".RData" ".rda" ".Rda" ".RDA"}}'),
defaultextension=".RData", initialfile=paste(activeDataSet(), ".RData", sep="")))
savefile <- removeRedundantExtension(savefile)
if (savefile == "") return()
savefile <- sub(".RData.RData$", ".RData", savefile)
cmd <- paste("save(\"",activeDataSet(),"\",file=\"",savefile,"\")",sep="")
eval(parse(text=cmd))
command <- paste('load("',savefile, '")', sep="")
doItAndPrint(command)
}
tkfocus(CommanderWindow())
}
OKCancelHelp(helpSubject="editDataset")
tkgrid(labelRcmdr(top, text=gettextRcmdr("Enter name for data set:")), entryDsname, sticky="e")
tkgrid(buttonsFrame, columnspan="2", sticky="w")
tkgrid.configure(entryDsname, sticky="w")
dialogSuffix(focus=entryDsname)
}
variablesandtypesDataSet <- function(){
# To ensure that menu name is included in pot file
gettext("Variables and types in active data set", domain="R-RcmdrPlugin.TeachStat")
doItAndPrint(paste0("listTypesVariables(\"", ActiveDataSet(), "\")"))
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.