Bertini input

NAMESPACE

@@ -24,6 +24,8 @@ export(poly_optim)
 export(poly_solve)
 export(sample_component)
 export(set_bertini_path)
+export(sharpening_module)
+export(user_defined_homotopy)
 export(variety)
 export(witness_set_print)
 import(mpoly)

R/bertini.R

@@ -9,6 +9,8 @@
 #' @param quiet show bertini output
 #' @param output the type of output expected (zero-dimensional or positive-dimensional)
 #' @param parameter_homotopy logical indicating if the run is a parameter homotopy.
+#' @param start_points an optional specification of the starting system in a list of points.
+#'  This is usually only specified for user-defined homotopies.
 #' @return an object of class bertini
 #' @export bertini
 #' @examples
@@ -116,8 +118,8 @@ bertini <- function(code,
                     dir = tempdir(),
                     quiet = TRUE,
                     output = c("zero_dim", "pos_dim"),
-                    parameter_homotopy = FALSE){
-
+                    parameter_homotopy = FALSE,
+                    start_points = list()){
 
   output <- match.arg(output)
 
@@ -134,6 +136,18 @@ bertini <- function(code,
   # make bertini file
   write_bertini(code, where = scratch_dir)
 
+  # if start_points exist, parse and write to file
+  if(length(start_points) > 0) {
+
+    # parse
+    points <- lapply(start_points, function(x) glue_collapse(glue("{Re(x)} {Im(x)}"), sep = "\n"))
+    start_file <- glue("{length(start_points)} \n\n{glue_collapse(points, sep = '\n\n')}")
+
+    # make
+    writeLines(start_file, file.path(scratch_dir, "start"))
+
+  }
+
 
   # switch to temporary directory, run bertini
   user_working_directory <- getwd()
@@ -169,10 +183,10 @@ bertini <- function(code,
     if("singular_solutions" %in% files) out$singular_solutions <- parse_bertini_singular_solutions(out)
     if("real_finite_solutions" %in% files) out$real_finite_solutions <- parse_bertini_real_finite_solutions(out)
     if("raw_solutions" %in% files) out$raw_solutions <- parse_bertini_raw_solutions(out)
-   #if("midpath_data" %in% files) out$midpath_data <- parse_bertini_midpath_data(out)
-   #if("start" %in% files) out$start <- parse_bertini_start(out)
+    if("midpath_data" %in% files) out$midpath_data <- parse_bertini_midpath_data(out)
+    if("start" %in% files) out$start <- parse_bertini_start(out)
     if("failed_paths" %in% files) out$failed_paths <- parse_bertini_failed_paths(out)
-
+    if("real_solutions" %in% files) out$real_solutions <- parse_bertini_real_solutions(out)
 
     # add code and directory
     out$raw_output <- raw_output
@@ -461,6 +475,11 @@ parse_bertini_midpath_data <- function(rawOutput){
     complex(1, x[1], x[2])
   }, complex(1))
 
+  if(length(mdpthPts) %% p != 0) {
+    vars <- vars[-p]
+    p <- p - 1
+  }
+
   mdpthPts <- matrix(mdpthPts, ncol = p, byrow = TRUE)
   colnames(mdpthPts) <- vars
 
@@ -479,7 +498,6 @@ parse_bertini_midpath_data <- function(rawOutput){
 
 parse_bertini_start <- function(rawOutput){
 
-browser()
   # check for no finite solutions
   if(
     length(rawOutput$start) == 1 &&
@@ -504,6 +522,11 @@ browser()
     complex(1, x[1], x[2])
   }, complex(1))
 
+  if(length(startPts) %% p != 0) {
+    vars <- vars[-p]
+    p <- p - 1
+  }
+
   startPts <- matrix(startPts, ncol = p, byrow = TRUE)
   colnames(startPts) <- vars
 
@@ -525,3 +548,26 @@ parse_bertini_failed_paths <- function(rawOutput){
 
   rawOutput$failed_paths
 }
+
+parse_bertini_real_solutions <- function(rawOutput){
+
+  # check for no finite solutions
+  if(str_sub(rawOutput$real_solutions[1], 1, 1) == "0") return(FALSE)
+
+  # get variables
+  vars <- str_replace(rawOutput$main_data[2], "Variables:  ", "")
+  vars <- str_split(vars, " ")[[1]]
+  p <- length(vars)
+
+  # grab output, format and return
+  rSolns <- rawOutput$real_solutions
+  rSolns <- rSolns[-c(1,2)]
+  rSolns <- rSolns[-length(rSolns)]
+
+  rSolns <- strsplit(rSolns, " ")[nchar(rSolns) > 0]
+  rSolns <- vapply(rSolns, function(x) as.numeric(x[1]), numeric(1))
+  rSolns <- matrix(rSolns, ncol = p, byrow = TRUE)
+  colnames(rSolns) <- vars
+
+  rSolns
+}

R/bertini_input.R

@@ -5,10 +5,10 @@
 #' a Bertini input file. By default, \code{bertini_input} will create an
 #' object that will be parsed as a total-degree homotopy in Bertini by grouping
 #' all variables present, either in \code{varorder} or infered from
-#' \code{mpolyList}, together in one variable group.
+#' \code{polys}, together in one variable group.
 #'
 #'
-#' @param mpolyList system of polynomials as either a character vector or mpolyList.
+#' @param polys system of polynomials as either a character vector or mpolyList.
 #' @param varorder an optional specification of the variable order.
 #' @param definitions an optional named list of the definitions to be given to
 #'    Bertini. The definitions name all arguments used in the polynomial and
@@ -42,25 +42,24 @@
 #'
 #' # subfunction example from Bertini
 #' polys <- mp(c("S*T*(x-2)", "S*U*(y-2)", "S*T*U*(z-2)"))
-#' subfunctions <- list("S" = "x^2 + y^2 + z^2 - 1",
-#'                      "T" = "y - x^2",
-#'                      "U" = "x*y - z")
+#' subfunctions <- list(S = "x^2 + y^2 + z^2 - 1",
+#'                      T = "y - x^2",
+#'                      U = "x*y - z")
 #' bertini_input(polys, subfunctions = subfunctions)
 #' }
-bertini_input <- function(mpolyList,
+bertini_input <- function(polys,
                           varorder,
                           definitions = list(),
                           configurations = list(),
                           subfunctions = list()
                           ) {
 
-  if(is.character(mpolyList)) mpolyList <- mp(mpolyList)
-  if(is.mpoly(mpolyList)) mpolyList <- structure(list(mpolyList), class = "mpolyList")
-  stopifnot(is.mpolyList(mpolyList))
+  if(is.character(polys)) polys <- mp(polys)
+  if(is.mpoly(polys)) polys <- mpolyList(polys)
+  stopifnot(is.mpolyList(polys))
 
   # sort out variables
-  # sort out variables
-  vars <- mpoly::vars(mpolyList)
+  vars <- mpoly::vars(polys)
 
   if(!missing(varorder) && !all(sort(vars) == sort(varorder))) stop(
     "If varorder is provided, it must contain all of the variables.",
@@ -77,7 +76,7 @@ bertini_input <- function(mpolyList,
 
 
   # make function names
-  fun_names <- str_c("f", 1:length(mpolyList))
+  fun_names <- str_c("f", 1:length(polys))
 
   if(length(definitions) == 0) {
     defs_block <- list(
@@ -91,9 +90,9 @@ bertini_input <- function(mpolyList,
     }
 
     # check if all variables are in the definitions
-    new_defs <- definitions[!names(definitions) == "function"]
+    new_defs <- definitions[!(names(definitions) == "function" | names(definitions) == "pathvariable")]
 
-    if(!all(unlist(new_defs) %in% vars)) {
+    if(!all(unlist(new_defs) %in% vars | unlist(new_defs) %in% names(subfunctions))) {
       stop("The definitions block must contain all variables")
     }
 
@@ -108,7 +107,7 @@ bertini_input <- function(mpolyList,
     config_block = configurations,
     defs_block = defs_block,
     subfun_block = subfunctions,
-    funs_block = mpolyList
+    funs_block = polys
   )
 
   struct <- structure(struct, class = "bertini_input")

R/parameter_homotopy.R

@@ -86,9 +86,7 @@ parameter_homotopy <- function(input,
   struct <- modify_config(struct, parameterhomotopy = 2)
 
   function(data) {
-    real <- Re(data)
-    imaginary <- Im(data)
-    final_data <- glue("{real} {imaginary};")
+    final_data <- glue("{Re(data)} {Im(data)};")
     final_params <- glue("{length(data)} \n\n{glue_collapse(final_data, sep = '\n')}")
     writeLines(final_params, file.path(scratch_dir, "final_parameters"))
 

R/print.bertini.R

@@ -33,6 +33,15 @@ print.bertini <- function(x, digits = 3, ...){
 
   p <- length(vars)
 
+  ## trying to handle user-defined homotopies
+  if(!"finite_solutions" %in% names(x)) {
+    x$finite_solutions <- x$raw_solutions
+  }
+  if(!"real_finite_solutions" %in% names(x) && "real_solutions" %in% names(x)) {
+    x$real_finite_solutions <- x$real_solutions
+  }
+
+
   ## determine number of solutions and kinds
   nFSolns  <- nrow(x$finite_solutions);      if(is.null(nFSolns))  nFSolns <- 0L
   nNsSolns <- nrow(x$nonsingular_solutions); if(is.null(nNsSolns)) nNsSolns <- 0L
@@ -41,7 +50,8 @@ print.bertini <- function(x, digits = 3, ...){
 
   ## print positive dimensional solution
   if (all(c(nFSolns, nNsSolns, nSSolns, nRSolns) == 0L)) {
-    message("Positive dimensional solution; print method not yet implemented.")
+    message("Positive dimensional solution or error at the Bertini level.
+            If expecting a positive-dimensional solution set, use output = 'pos_dim'.")
     return(invisible())
   }