From 51d78365839364617fd740d5612fc6f245cefe66 Mon Sep 17 00:00:00 2001 From: Danny Parsons Date: Tue, 24 Jan 2017 17:31:57 +0000 Subject: [PATCH] added methods for links and keys --- instat/clsRLink.vb | 4 ++ instat/dlgOneVariableGraph.vb | 18 ++++---- .../InstatObject/R/Backend_Components/link.R | 6 ++- instat/static/InstatObject/R/data_object_R6.R | 25 ++++++++++- .../static/InstatObject/R/instat_object_R6.R | 41 +++++++++++++++++-- instat/ucrReceiverMultiple.vb | 6 +++ instat/ucrReceiverSingle.vb | 6 +++ 7 files changed, 88 insertions(+), 18 deletions(-) diff --git a/instat/clsRLink.vb b/instat/clsRLink.vb index aa176364ece..a6b6806ac87 100644 --- a/instat/clsRLink.vb +++ b/instat/clsRLink.vb @@ -513,6 +513,10 @@ Public Class RLink clsGetItems.SetRCommand(strInstatDataObject & "$get_graph_names") Case "dataframe" clsGetItems.SetRCommand(strInstatDataObject & "$get_data_names") + Case "link" + clsGetItems.SetRCommand(strInstatDataObject & "$get_link_names") + Case "key" + clsGetItems.SetRCommand(strInstatDataObject & "$get_key_names") End Select clsGetItems.AddParameter("as_list", "TRUE") lstView.Clear() diff --git a/instat/dlgOneVariableGraph.vb b/instat/dlgOneVariableGraph.vb index 2a43d73639d..a74111b8494 100644 --- a/instat/dlgOneVariableGraph.vb +++ b/instat/dlgOneVariableGraph.vb @@ -45,12 +45,6 @@ Public Class dlgOneVariableGraph End Sub Private Sub InitialiseDialog() - 'Define the default RFunction - clsDefaultRFunction.SetRCommand(frmMain.clsRLink.strInstatDataObject & "$graph_one_variable") - clsDefaultRFunction.AddParameter("numeric", Chr(34) & "geom_boxplot" & Chr(34)) - clsDefaultRFunction.AddParameter("categorical", Chr(34) & "geom_bar" & Chr(34)) - clsDefaultRFunction.AddParameter("output", Chr(34) & "facets" & Chr(34)) - clsDefaultRFunction.AddParameter("coord_flip", "TRUE") ucrPnlOutput.SetParameter(New RParameter("output")) ucrPnlOutput.AddRadioButton(rdoFacets, Chr(34) & "facets" & Chr(34)) @@ -64,7 +58,6 @@ Public Class dlgOneVariableGraph ucrSelectorOneVarGraph.SetParameter(New RParameter("data_name")) ucrSelectorOneVarGraph.SetParameterIsString() - clsDefaultRFunction.AddParameter(ucrSelectorOneVarGraph.GetParameter(), 0) ucrChkFlip.SetText("Flip Coordinates") ucrChkFlip.SetParameter(New RParameter("coord_flip")) @@ -76,6 +69,13 @@ Public Class dlgOneVariableGraph ucrOneVarGraphSave.SetDataFrameSelector(ucrSelectorOneVarGraph.ucrAvailableDataFrames) ucrBase.clsRsyntax.bExcludeAssignedFunctionOutput = False ucrBase.clsRsyntax.iCallType = 3 + + 'Define the default RFunction + clsDefaultRFunction.SetRCommand(frmMain.clsRLink.strInstatDataObject & "$graph_one_variable") + clsDefaultRFunction.AddParameter("numeric", Chr(34) & "geom_boxplot" & Chr(34)) + clsDefaultRFunction.AddParameter("categorical", Chr(34) & "geom_bar" & Chr(34)) + clsDefaultRFunction.AddParameter("output", Chr(34) & "facets" & Chr(34)) + clsDefaultRFunction.AddParameter(ucrSelectorOneVarGraph.GetParameter(), 0) End Sub Private Sub ReopenDialog() @@ -134,9 +134,7 @@ Public Class dlgOneVariableGraph End Sub 'When any of the ucrCore controls have been changed we update the R Code to match the contents - Private Sub AllControls_ControlValueChanged(ucrChangedControl As ucrCore) Handles ucrSelectorOneVarGraph.ControlValueChanged, ucrChkFlip.ControlValueChanged, ucrReceiverOneVarGraph.ControlValueChanged, ucrSelectorOneVarGraph.ControlValueChanged - 'The control that has changed updates the R code + Private Sub AllControls_ControlValueChanged(ucrChangedControl As ucrCore) Handles ucrReceiverOneVarGraph.ControlValueChanged CheckDataType() - ucrChangedControl.UpdateRCode() End Sub End Class \ No newline at end of file diff --git a/instat/static/InstatObject/R/Backend_Components/link.R b/instat/static/InstatObject/R/Backend_Components/link.R index 74712f2211a..c61125cf66f 100644 --- a/instat/static/InstatObject/R/Backend_Components/link.R +++ b/instat/static/InstatObject/R/Backend_Components/link.R @@ -27,7 +27,7 @@ link$set("public", "data_clone", function() { } ) -instat_object$set("public", "add_link", function(from_data_frame, to_data_frame, link_pairs, type) { +instat_object$set("public", "add_link", function(from_data_frame, to_data_frame, link_pairs, type, link_name) { if(length(names(link_pairs)) != length(link_pairs)) stop("link_pairs must be a named vector or list.") if(!self$link_exists_between(from_data_frame, to_data_frame)) { # This means when creating a link to single value data frame, there will be no key in to_data_frame @@ -38,7 +38,9 @@ instat_object$set("public", "add_link", function(from_data_frame, to_data_frame, message("New key created") } new_link <- link$new(from_data_frame = from_data_frame, to_data_frame = to_data_frame, link_columns = list(link_pairs), type = type) - private$.links[[length(private$.links) + 1]] <- new_link + if(missing(link_name)) link_name <- next_default_item("link", names(private$.links)) + if(link_name %in% names(private$.links)) warning("A link called ", link_name, " already exists. It wil be replaced.") + private$.links[[link_name]] <- new_link } else { index <- integer(0) diff --git a/instat/static/InstatObject/R/data_object_R6.R b/instat/static/InstatObject/R/data_object_R6.R index 0e32b7d9967..9e65d8ba7a5 100644 --- a/instat/static/InstatObject/R/data_object_R6.R +++ b/instat/static/InstatObject/R/data_object_R6.R @@ -1463,8 +1463,18 @@ data_object$set("public", "has_key", function() { } ) -data_object$set("public", "get_keys", function() { - return(private$keys) +data_object$set("public", "get_keys", function(key_name) { + if(!missing(key_name)) { + if(!key_name %in% names(private$keys)) stop(key_name, " not found.") + return(private$keys[[key_name]]) + } + else return(private$keys) +} +) + +data_object$set("public", "remove_key", function(key_name) { + if(!key_name %in% names(private$keys)) stop(key_name, " not found.") + private$keys[[key_name]] <- NULL } ) @@ -1967,4 +1977,15 @@ data_object$set("public","infill_missing_dates", function(date_name, factors) { } } } +) + +data_object$set("public","get_key_names", function(include_overall = TRUE, include, exclude, include_empty = FALSE, as_list = FALSE, excluded_items = c()) { + key_names <- names(private$keys) + if(as_list) { + out <- list() + out[[self$get_metadata(data_name_label)]] <- key_names + } + else out <- key_names + return(out) +} ) \ No newline at end of file diff --git a/instat/static/InstatObject/R/instat_object_R6.R b/instat/static/InstatObject/R/instat_object_R6.R index e8e46e04457..211b37d2ffb 100644 --- a/instat/static/InstatObject/R/instat_object_R6.R +++ b/instat/static/InstatObject/R/instat_object_R6.R @@ -932,13 +932,17 @@ instat_object$set("public","has_key", function(data_name) { } ) -instat_object$set("public","get_keys", function(data_name) { - self$get_data_objects(data_name)$get_keys() +instat_object$set("public","get_keys", function(data_name, key_name) { + self$get_data_objects(data_name)$get_keys(key_name) } ) -instat_object$set("public","get_links", function() { - return(private$.links) +instat_object$set("public","get_links", function(link_name) { + if(!missing(link_name)) { + if(!link_name %in% names(private$keys)) stop(link_name, " not found.") + return(private$.links[[link_name]]) + } + else return(private$.links) } ) @@ -1069,4 +1073,33 @@ instat_object$set("public", "import_NetCDF", function(nc_data, data_names = c()) instat_object$set("public", "infill_missing_dates", function(data_name, date_name, factors) { self$get_data_objects(data_name)$infill_missing_dates(date_name = date_name, factor = factors) } +) + +instat_object$set("public", "get_key_names", function(data_name, include_overall = TRUE, include, exclude, include_empty = FALSE, as_list = FALSE, excluded_items = c()) { + self$get_data_objects(data_name)$get_key_names(include_overall = include_overall, include, exclude, include_empty = include_empty, as_list = as_list, excluded_items = excluded_items) +} +) + +instat_object$set("public", "get_link_names", function(data_name, include_overall = TRUE, include, exclude, include_empty = FALSE, as_list = FALSE, excluded_items = c(), exclude_self_links = TRUE) { + if(exclude_self_links) { + out <- c() + i <- 1 + for(link in private$.links) { + if(link$from_data_frame != link$to_data_frame) out <- c(out, names(private$.links)[i]) + i <- i + 1 + } + } + else out <- names(private$.links) + if(as_list) { + lst <- list() + lst[[overall_label]] <- out + return(lst) + } + else return(out) +} +) + +instat_object$set("public", "remove_key", function(data_name, key_name) { + self$get_data_objects(data_name)$remove_key(key_name) +} ) \ No newline at end of file diff --git a/instat/ucrReceiverMultiple.vb b/instat/ucrReceiverMultiple.vb index f091d463fdc..cd64532bf30 100644 --- a/instat/ucrReceiverMultiple.vb +++ b/instat/ucrReceiverMultiple.vb @@ -160,6 +160,12 @@ Public Class ucrReceiverMultiple Case "dataframe" clsGetVariablesFunc.SetRCommand(frmMain.clsRLink.strInstatDataObject & "$get_data_frame") clsGetVariablesFunc.AddParameter("data_name", GetVariableNames()) + Case "key" + clsGetVariablesFunc.SetRCommand(frmMain.clsRLink.strInstatDataObject & "$get_keys") + clsGetVariablesFunc.AddParameter("key_name", GetVariableNames()) + Case "link" + clsGetVariablesFunc.SetRCommand(frmMain.clsRLink.strInstatDataObject & "$get_links") + clsGetVariablesFunc.AddParameter("link_name", GetVariableNames()) End Select 'TODO make this an option set in Options menu 'clsRSyntax.SetAssignTo(MakeValidRString(strCurrDataFrame) & "_temp", clsFunction:=clsGetVariablesFunc) diff --git a/instat/ucrReceiverSingle.vb b/instat/ucrReceiverSingle.vb index 6ddd7d4ee12..a47138bf973 100644 --- a/instat/ucrReceiverSingle.vb +++ b/instat/ucrReceiverSingle.vb @@ -163,6 +163,12 @@ Public Class ucrReceiverSingle Case "dataframe" clsGetVariablesFunc.SetRCommand(frmMain.clsRLink.strInstatDataObject & "$get_data_frame") clsGetVariablesFunc.AddParameter("data_name", GetVariableNames()) + Case "key" + clsGetVariablesFunc.SetRCommand(frmMain.clsRLink.strInstatDataObject & "$get_keys") + clsGetVariablesFunc.AddParameter("key_name", GetVariableNames()) + Case "link" + clsGetVariablesFunc.SetRCommand(frmMain.clsRLink.strInstatDataObject & "$get_links") + clsGetVariablesFunc.AddParameter("link_name", GetVariableNames()) End Select 'TODO make this an option set in Options menu