Merge pull request IDEMSInternational#2550 from dannyparsons/keyslinks

added methods for links and keys
lilyclements · Jan 24, 2017 · 5805cd1 · 5805cd1
2 parents 25bf77a + 51d7836
commit 5805cd1
Show file tree

Hide file tree

Showing 7 changed files with 88 additions and 18 deletions.
diff --git 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
@@ -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
diff --git 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
@@ -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)
+}
 )
diff --git 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)
+}
 )
diff --git 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
@@ -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