Convert an expression to a Function

Question

I need a function which can take an expression and return a pure function based on the symbols in the expression. The symbols might have values so must be protected from evaluation. It is probably easiest to give an example:

I would like to evaluate something like

x = y = 1;
extractPureFunction[Sin[Pi x^2] + y]

and obtain

Function[{x, y}, Sin[Pi x^2] + y]

or

(Sin[Pi #1^2] + #2) &

Any ideas?

Answer 1

What about taking the symbols not in heads that haven't got the NumericFunction or Constant or Protected attribute (thanks @OleksandrR) and that are in the Global` context? The condition can easily be tweaked, and also one can easily add options on attributes, contexts, or extra symbols to be included or always excluded of argmuents

SetAttributes[{extractPureFunction, condition}, HoldFirst];
condition[i_Symbol] := 
  FreeQ[Attributes@i, NumericFunction | Constant | Protected] && 
   Context@i == "Global`";


extractPureFunction[expr_] := 
 Union@Cases[Unevaluated@expr, 
     i_Symbol?condition :> Hold[i], {0, Infinity}]~Thread~Hold /. 
  Hold[vars_] :> Function[vars, expr]


extractPureFunction[Sin[x] x + Pi + y - Total@Through@{Tan, ArcTan}[E]]

Function[{x, y},Sin[x] x + [Pi] + y - Total[Through[{Tan, ArcTan}[E]]]]

Note, this doesn't respect inner scoping constructs so variables from inner Functions or Modules for example would get listed as arguments

Answer 2

Well, since you defined x=y=1, evaluation semantics will make it very difficult to get at them inside your mathematical expression.

The general issue is one of extracting the variables. I show a way to go about that here. With getAllVariables as defined therein, one can then do as below.

extractPureFunction[expr_] := Module[{vars, func},
  vars = Cases[getAllVariables[expr],_Symbol];
  func[vars, expr] /. func -> Function]

Test:

In[38]:= extractPureFunction[Sin[Pi t^2] + w]

(* Out[38]= Function[{w, t}, w + Sin[Pi*t^2]] *)

Answer 3

Here's my approach, which is similar to Rojo's in some ways. I'm taking the simple approach that any symbol not in System` is a user variable. (Adjust the condition as needed.)

SetAttributes[extractPureFunction, HoldAll]
SetAttributes[heldVariables, HoldAll]

heldVariables[e_] := 
 Thread[Union[
   Cases[HoldForm[e], 
    s_Symbol /; Context[s] =!= "System`" :> Hold[s], Infinity]], Hold]

extractPureFunction[e_] := 
 ReleaseHold[Function @@@ Thread[{heldVariables[e], Hold[e]}, Hold]]

Here's the test case:

x = y = 1;
extractPureFunction[Sin[Pi x^2] + y]

(*  ==> Function[{x, y}, Sin[\[Pi] x^2] + y]  *)

Answer 4

Since I put something together to do this this past fall, I guess I should throw my hat in the ring, too. I think it is close to water tight, but I can't be sure.

First, we need to determine what the variables in the expression are

Clear[GetVariables]
SetAttributes[GetVariables, HoldFirst];
GetVariables[expr_, f_:Identity, excludedContexts:{__String}:{"System`"}]:=
Cases[Unevaluated[expr], 
  a_Symbol /; 
    !(   MemberQ[excludedContexts, Context[a]] 
      || MemberQ[Attributes[a], Locked | ReadProtected]
     ) :> f[a], 
  {0, Infinity}
]//DeleteDuplicates

Unlike the others, it provides flexibility in specifying which Contexts are to be excluded, and removes from consideration both Locked and ReadProtected symbols. As a flaw, it only looks at symbols, so it won't distinguish between Subscript[a,1] and Subscript[a,2]. The second parameter here is special, it allows us to put wrappers, such as Hold, around an accepted symbol to prevent its execution.

Second, we need to use it:

ClearAll[MakeFunction]
Options[MakeFunction]={VariableList->Automatic};
SetAttributes[MakeFunction, HoldFirst];

(* This first form allows pure functions to be used *)
MakeFunction[afcn_Function, opts:OptionsPattern[]]:= afcn

MakeFunction[fexpr_, opts:OptionsPattern[] ]:= 
Module[{vars},
vars = If[OptionValue[VariableList]===Automatic,
             (* GetVariables returns {Hold[x_] ..} we want Hold[{x_ ..}] *)
             Distribute[Sort[GetVariables[fexpr, Hold]], Hold],
             OptionValue[Automatic, Automatic, VariableList, Hold]
           ];
Function @@ Join[vars, Hold[fexpr]]
]

There are a couple things to notice here. First, it allows for pure functions to be passed to it. This is merely for convenience as it makes it more broadly applicable. Second, the option VariableList allows the user to specify what the variables actually are because if we know them already, we might as well use them. This has the added benefit of allowing the user to change the order of the parameters which defaults to lexical sorting.

Through @ (MakeFunction /@ {x^2, Sin[x y^2], x + I y})[3, 4]
(* {9, Sin[48], 3 + 4 I} *)

Through @ (MakeFunction[#, VariableList -> {y, x}] & /@ {x^2, Sin[x y^2], x + I y})[3, 4]
(* {16, Sin[36], 4 + 3 I} *)

Answer 5

I'm sure this is far from watertight, but it seems to work for the expression I've tried. The hard bit was preventing Mathematica from evaluating the symbols prematurely.

toFunction[exp_] := Module[{exp1, syms},
  exp1 = ToExpression[exp, InputForm, Hold];
  syms = SymbolName /@ Pick[#, Not[NumericQ[Unevaluated[#]]] & /@ #] &@
    ReleaseHold[{Unevaluated /@ Level[exp1, {-1}, Hold]}];
  ToExpression["Function[ {" <> StringJoin[Riffle[syms, ","]] <> "}," <> exp <> "]"]]

Example:

a = 2;
ff = toFunction["Sin[abc a+b+Pi/5]^4-5"]

(* Function[{abc, a, b}, Sin[abc a + b + \[Pi]/5]^4 - 5] *)

Edit: I missed the fact that the argument was given as an expression and not as a string. In that case you could do something like

SetAttributes[toFunction, HoldAll]
toFunction[exp_] := Module[{syms},
  syms = SymbolName /@ Pick[#, Not[NumericQ[Unevaluated[#]]] & /@ #] &@
    ReleaseHold[{(Unevaluated /@ Level[Hold[exp], {-1}, Hold])}];
  ToExpression[
   "Function[ {" <> StringJoin[Riffle[syms, ","]] <> "}," <> 
    ToString[Unevaluated[exp], InputForm] <> "]"]]

Answer 6

Here's my approach. It works by picking out only the non-heads and then filtering out the built-in constants like π, E and numbers.

ClearAll[toPureFunction]
SetAttributes[toPureFunction, HoldAll]
toPureFunction[expr_] := With[{constantQ = MemberQ[Attributes[#], Constant] &}, 
    Module[{vars, func}, 
        vars = Quiet[
            Cases[
                HoldForm@expr // Level[#, {-1}, Unevaluated] &, 
                x_Symbol?(OwnValues[#] =!= {} || ! constantQ[#] &) :> Hold@x], 
            OwnValues::sym];

        Quiet[Function[Evaluate@DeleteDuplicates@vars, expr] // ReleaseHold, Function::flpar]
    ]
]

Here's the output on some of the examples used in the question and other answers:

toPureFunction[Sin[π x^2] + y]
(* Function[{x, y}, Sin[π x^2] + y] *)

toPureFunction[Sin[x] x + Pi + y - Total@Through@{Tan, ArcTan}[E]]
(* Function[{x, y}, Sin[x] x + π + y - Total[Through[{Tan, ArcTan}[E]]]] *)