Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Rework new and edit function

  • Loading branch information...
commit e5227da6af91fed0413cb9bec31aac5f5fb0c7da 1 parent 3bf4ab6
@jfisher-usgs authored
View
23 R/EditFunction.R
@@ -9,7 +9,7 @@ EditFunction <- function(cols, index=NULL, fun=NULL, value.length=NULL,
SaveFunction <- function() {
txt <- as.character(tclvalue(tkget(frame2.txt.2.1, "1.0", "end-1c")))
if (txt == "") {
- rtn <<- list(fun="", class=NA)
+ rtn <<- list(fun="")
} else {
fun <- txt
pattern <- paste("\"", ids, "\"", sep="")
@@ -25,34 +25,35 @@ EditFunction <- function(cols, index=NULL, fun=NULL, value.length=NULL,
type="ok", parent=tt)
return()
}
- val <- EvalFunction(txt, cols)
- if (inherits(val, "try-error")) {
+ obj <- EvalFunction(txt, cols)
+ if (inherits(obj, "try-error")) {
msg <- "Function results in error during evaluation, try revising."
- tkmessageBox(icon="error", message=msg, detail=val, title="Error",
+ tkmessageBox(icon="error", message=msg, detail=obj, title="Error",
type="ok", parent=tt)
return()
}
- if (!is.null(value.length) && length(val) != value.length) {
+ if (!is.null(value.length) && length(obj) != value.length) {
msg <- paste("Evaluated function must be of length ", value.length,
", try revising.", sep="")
- dtl <- paste("Resulting object is currently of length ", length(val),
+ dtl <- paste("Resulting object is currently of length ", length(obj),
".", sep="")
tkmessageBox(icon="error", message=msg, detail=dtl, title="Error",
type="ok", parent=tt)
return()
}
- if (!is.null(value.class) && !inherits(val, value.class)) {
+ if (!is.null(value.class) && !inherits(obj, value.class)) {
msg <- paste("A query must result in an object of class \"", value.class,
"\". The evaluated function is an object of class \"",
- class(val), "\", please revise.", sep="")
+ class(obj), "\", please revise.", sep="")
tkmessageBox(icon="error", message=msg, title="Error", type="ok",
parent=tt)
return()
}
- rtn <<- list(fun=txt, class=class(val)[1])
+ rtn <<- list(fun=txt, class=class(obj)[1], summary=SummarizeData(obj),
+ sample=na.omit(obj)[1])
}
tclvalue(tt.done.var) <- 1
}
@@ -256,7 +257,7 @@ EditFunction <- function(cols, index=NULL, fun=NULL, value.length=NULL,
rtn <- NULL
ids <- vapply(cols, function(i) i$id, "")
- cls <- vapply(cols, function(i) i$class, "")
+ cls <- vapply(cols, function(i) i$class, "")
if (!is.null(index)) {
edit.fun.id <- ids[index]
ids <- ids[-index]
@@ -485,7 +486,7 @@ EditFunction <- function(cols, index=NULL, fun=NULL, value.length=NULL,
frame2 <- tkframe(pw, relief="flat", padx=0, pady=0)
txt <- "Define function"
- if (!is.null(index))
+ if (!is.null(index) && edit.fun.id != "")
txt <- paste(txt, " for \"", edit.fun.id, "\"", sep="")
frame2.lab.1.1 <- ttklabel(frame2, text=txt, foreground="#414042")
View
54 R/ManageData.R
@@ -110,7 +110,6 @@ ManageData <- function(cols, vars, parent=NULL) {
}
# Save name
-
SetVarId(idx)
}
@@ -138,7 +137,7 @@ ManageData <- function(cols, vars, parent=NULL) {
# Update format
saved.fmt <- cols[[idx]]$format
- if (is.null(saved.fmt)) {
+ if (is.null(saved.fmt) || saved.fmt == "") {
if (saved.class %in% c("character", "logical")) {
saved.fmt <- "%s"
} else if (saved.class == "numeric") {
@@ -262,23 +261,38 @@ ManageData <- function(cols, vars, parent=NULL) {
SaveNewVar <- function() {
SaveNb()
- id <- "New Variable"
- n <- length(cols)
- cols[[n + 1]] <<- list(name=id, format="%s", class="logical", fun="")
- tcl("lappend", list.var, id)
+ new.name <- "New Variable"
+ idx <- length(cols) + 1L
+
+ cols[[idx]] <- list(id="", name=new.name, class="", fun="")
+
+ n <- cols[[1]]$summary$Count
+ f <- EditFunction(cols, index=idx, value.length=n, parent=tt)
+
+ if (is.null(f$fun) || f$fun == "")
+ return()
+
+ cols <<- cols
+ cols[[idx]]$fun <<- f$fun
+ cols[[idx]]$class <<- f$class
+ cols[[idx]]$summary <<- f$summary
+ cols[[idx]]$sample <<- f$sample
+
+ tcl("lappend", list.var, new.name)
tkselection.clear(frame1.lst, 0, "end")
- tkselection.set(frame1.lst, n, n)
- tkyview(frame1.lst, n)
+ tkselection.set(frame1.lst, idx - 1L, idx - 1L)
+ tkyview(frame1.lst, idx - 1L)
UpdateNb()
- SetVarId()
- CallEditFunction()
+ SetVarId(idx)
}
# Edit a variables function formula
CallEditFunction <- function() {
+ SaveNb()
+
idx <- as.integer(tkcurselection(frame1.lst)) + 1L
if (length(idx) == 0)
return()
@@ -286,11 +300,7 @@ ManageData <- function(cols, vars, parent=NULL) {
n <- cols[[1]]$summary$Count
f <- EditFunction(cols, index=idx, value.length=n, parent=tt)
- if (cols[[idx]]$fun == "" & (is.null(f$fun) || f$fun == "")) {
- DeleteVar()
- return()
- }
- if (is.null(f))
+ if (is.null(f$fun))
return()
if (f$fun == "") {
msg <- paste("Nothing has been defined for this function; therefore,\n",
@@ -304,17 +314,11 @@ ManageData <- function(cols, vars, parent=NULL) {
return()
}
- cols[[idx]]$class <<- f$class
+ cols[[idx]]$fun <<- f$fun
+ cols[[idx]]$class <<- f$class
+ cols[[idx]]$summary <<- f$summary
+ cols[[idx]]$sample <<- f$sample
- tkconfigure(frame2.ent.2.2, state="normal")
- tclvalue(fmt.var) <- ""
- tkconfigure(frame2.ent.2.2, state="readonly")
- tkconfigure(frame2.txt.4.2, state="normal")
- tcl(frame2.txt.4.2, "delete", "1.0", "end")
- tkinsert(frame2.txt.4.2, "end", f$fun)
- tkconfigure(frame2.txt.4.2, state="disabled")
-
- SaveNb()
UpdateNb()
}
View
BIN  data/project.rda
Binary file not shown
View
8 man/EditFunction.Rd
@@ -31,9 +31,11 @@ pre-existing data frame or query building.
}
\value{
-Returns a list with two character components: \code{fun},
-the user defined function (when evaluated, this string must be parseable),
-and \code{class}, the object class of the evaluated function.
+Returns a list with two four components:
+\code{fun}, the user defined function (when evaluated, this string must be parseable);
+\code{class}, the object class of the evaluated function;
+\code{summary}, a numeric summary; and
+\code{sample} of the object.
}
\author{J.C. Fisher}
Please sign in to comment.
Something went wrong with that request. Please try again.