17
$\begingroup$

Yesterday I was looking at one of Henrik Schumacher's answers and realizing that it'd be useful to some of these functions more accessible for reuse. Copy-and-paste is nice, but better would be a convenient way to load the functions in Mathematica.

But I'd like something even more general than extracting all the functions for a single answer. Instead I'd like all the functions for a given user. (Bonus points for filtering by tags and votes).

How can we do this?


Potentially useful info:

I'll post what I've been working on for this in a bit, but I figure it's better to let others have a go first. To that effect, here's a nice little function that might be of use:

ServiceConnection to the StackExchange API

You can install this to get easy access to data stored on StackExchange: ServiceConnection Paclet

Extract all user answers

Here's a way to use the previous paclet to get user answers:

validSEConn[so_] :=

  ServiceConnections`ServiceInformation[so, "Name"] === 
   "StackExchange";
getUserID[se : _ServiceObject?validSEConn, userName_String] :=

  se["UserIDs", "site" -> "mathematica", "inname" -> userName][[1]];
getUserAnswers[
   se : _ServiceObject?validSEConn,
   userID_Integer, 
   numAnswers : _Integer : 100,
   selector : Except[_Integer] : None
   ] :=
  With[{sp =
     {
      "site" -> "mathematica",
      "id" -> ToString@userID, 
      "sort" -> "votes",
      "filter" -> "withbody"
      }
    },
   If[numAnswers < 100,
     se["UserAnswers", Sequence @@ sp, 
      "pagesize" -> ToString[numAnswers]],
     se["QueryIterate",
      "Request" -> "UserAnswers", 
      "MaxIterations" -> Ceiling[numAnswers/100],
      Sequence @@ sp
      ]
     ][Replace[
     selector, {None | All :> All, e_ :> Select[selector]}], 
    KeyDrop["owner"]]
   ];

To get Henrik Schumacher's 5 top answers, then, we'd use:

$se = ServiceConnect["StackExchange"];
getUserAnswers[$se, getUserID[$se, "Henrik"], 5]
$\endgroup$
  • 2
    $\begingroup$ Related (3535) $\endgroup$ – Carl Woll May 7 '18 at 1:27
6
$\begingroup$

The way I tackled this was to get the body of the answer as HTML (using a minor adaptation of what I provided in the question), imported this as an XMLObject, extracted the "code" blocks, then performed some simple analysis of the imported results. One nice thing about this approach is the functions for extracting code and doing the analysis will work on any web page with Mathematica code.

This works about 60% of the time I'd say, with most of the issue being in that simple analysis. The first parts are relatively simple. For function-heavy answers this will work well. For chunks of code designed to solve a single problem or which require lots of prep work this will not work so well.

The code block is at the end of this.

Basic Usage

We can use this stuff then to get all *Values assignments in a user's top 100 answers:

(* you can get this paclet here: https://paclets.github.io/PacletServer/serviceconnectionstackexchange.html *)
$se = ServiceConnect["StackExchange"];
henrikCode = getUserAnswerCode[$se, "Henrik Schumacher", 100];

If we wanted only those answers that pertained to a performance tuning question we can filter them like:

getUserAnswerCode[$se, "Henrik Schumacher",
 MemberQ[#question["tags"], "performance-tuning"] &]

Alternately if I wanted every single answer I could run:

getUserAnswerCode[$se, "Henrik Schumacher", All]

These two syntaxes (number of answers / filter function) can be used together, e.g. getting the answers to performance tuning questions in the top 500 answers:

getUserAnswerCode[$se, "Henrik Schumacher", 500, 
 MemberQ[#question["tags"], "performance-tuning"] &]

Then if I wanted to look at something that was defined in that answer that originally piqued my interest I could do:

KeySelect[henrikCode, StringContainsQ["Plateau"]][[1, "OwnValues", "getLaplacian"]] //
  Normal (* It's stored as a Dataset so the normal unwraps that*)

And get the following: (Note that I temporarily put the package context on the context path with System`Private`NewContextPath[{"StackExchangeFunctions`HenrikSchumacher`", "System`", "Global`"}] so it'd format nicely. This can be reverted with System`Private`RestoreContextPath[])

HoldComplete[
 getLaplacian = 
  Quiet[Block[{xx, x, PP, P, UU, U, VV, V, f, Df, u, Du, v, 
          Dv, g, integrant, quadraturepoints, quadratureweights}, 
        xx = Table[x[[i]], {i, 1, 2}]; 
    PP = Table[P[[i, j]], {i, 1, 3}, {j, 1, 3}]; 
         UU = Table[U[[i]], {i, 1, 3}]; VV = Table[V[[i]], {i, 1, 3}]; 
         f = Function[x, PP[[1]] + x[[1]]*(PP[[2]] - PP[[1]]) + 
               x[[2]]*(PP[[3]] - PP[[1]])]; 
    Df = Function[x, Evaluate[D[f[xx], {xx}]]]; 
         g = Function[x, Evaluate[Transpose[Df[xx]] . Df[xx]]]; 
         u = Function[x, UU[[1]] + x[[1]]*(UU[[2]] - UU[[1]]) + 
               x[[2]]*(UU[[3]] - UU[[1]])]; 
    Du = Function[x, Evaluate[D[u[xx], {xx}]]]; 
         v = Function[x, VV[[1]] + x[[1]]*(VV[[2]] - VV[[1]]) + 
               x[[2]]*(VV[[3]] - VV[[1]])]; 
    Dv = Function[x, Evaluate[D[v[xx], {xx}]]]; 
         integrant = 
     Function[x, Evaluate[D[D[Dv[xx] . Inverse[g[xx]] . Du[xx]*
                     Sqrt[Abs[Det[g[xx]]]], {UU}, {VV}]]]]; 
    quadraturepoints = {{1/3, 1/3}}; 
         quadratureweights = {1/2}; 
         With[{code = 
       N[quadratureweights . integrant /@ quadraturepoints] /. 
                 Part -> Compile`GetElement}, 
     Compile[{{P, _Real, 2}}, code, 
             CompilationTarget -> "C", 
      RuntimeAttributes -> {Listable}, 
             Parallelization -> True]]]]] 

Issues

Given that I'm mostly trying to extract functions, many blocks of code that aren't packaged up as functions can't be nicely extracted. In particular, Compile blocks that are wrapped in With for code injection can't really be gotten. That puts the brakes on getting lots of performance tuning code.

On the other hand, things like Leonid Shrifin's framework development type answers (e.g. this) which are entirely comprised of small functions and assignments may be scraped nicely:

leonidFBLCode =
  getUserAnswerCode[$se,
    "Leonid Shifrin", 
   StringContainsQ[#question["title"], "File-backed lists"] &
   ];

Then I can get one function in that answer with:

leonidFBLCode[[1, "DownValues", "LetL"]] // Normal

HoldComplete[
 LetL[{head_, tail__}, expr_] := 
  Block[{With}, Attributes[With] = {HoldAll}; 
   With[{head}, Evaluate[LetL[{tail}, expr]]]]]

Code Block

Here's all the code that went into this:

(*extractCode*)
extractCode[block_String]:=
 Replace[
  DeleteCases[
   Quiet@
   ToExpression[
    Cases[ImportString[block, {"HTML", "XMLObject"}],
     XMLElement["code", _, s_]:>StringJoin@DeleteCases[s, Except[_String]],
     \[Infinity]
     ],
    StandardForm,
    HoldComplete
    ],
   $Failed
   ],
  {
   {h__HoldComplete}:>
   Replace[
    Replace[Join[h],
     hc:HoldComplete[c__CompoundExpression]:>
     Thread[hc, HoldComplete]
     ],
    HoldComplete[first_, rest___]:>
    HoldComplete[CompoundExpression[first, rest]]
    ],
   _:>$Failed
   }
  ];

(*ignoredPatCases*)
ignoredPatCases[expr_, pats_, caseSpec:_List]:=
 Block[{mappo=<||>, protto},
   protto=
   expr/.p:pats:>
   RuleCondition[(mappo[Hash[HoldComplete[p]]]:=p; Hash[HoldComplete[p]]), True];
   Join@@Map[Cases[protto, #, Infinity]&, caseSpec]/.mappo
   ];

(*commonLocalSetHeads*)
$commonLocalSetHeads=
 _Module|_Block|_With|_DynamicModule|
 _Dynamic|_DynamicWrapper|_Button|_EventHandler;

(*extractCodeOwnValues*)
extractCodeOwnValues[code_HoldComplete]:=
 ignoredPatCases[
  code,
  $commonLocalSetHeads,
  {
   HoldPattern[(h:Set|SetDelayed)[s_Symbol, v_]]:>
   SymbolName[Unevaluated@s]:>HoldComplete[h[s, v]]
   }
  ];

(*extractCodeDownValues*)
seSymbol[s_]:=
 StringMatchQ[Context[s], "StackExchange*"];
seSymbol~SetAttributes~HoldFirst;
extractCodeDownValues[code_HoldComplete]:=
 ignoredPatCases[
  code,
  $commonLocalSetHeads,
  {
   HoldPattern[(h:Set|SetDelayed)[(s_Symbol?seSymbol)[args___], v_]]:>
   (SymbolName[Unevaluated@s]->HoldComplete[h[s[args], v]])
   }
  ];

(*extractCodeUpValues*)
notSeSymbol[s_]:=
 !StringMatchQ[Context[s], "StackExchange*"];
notSeSymbol~SetAttributes~HoldFirst;
extractCodeUpValues[code_HoldComplete]:=
 ignoredPatCases[
  code,
  $commonLocalSetHeads,
  {
   HoldPattern[(h:TagSet|TagSetDelayed)[s_Symbol, spec_, v_]]:>
    (SymbolName[Unevaluated@s]->HoldComplete[h[spec, v]]),
   HoldPattern[
    (h:Set|SetDelayed)[
     spec:(_Symbol?notSeSymbol)[s_Symbol?seSymbol, ___],
     v_
     ]
    ]:>
    (SymbolName[Unevaluated@s]->HoldComplete[h[spec, v]])
   }
  ];

(*extractCodeSubValues*)
extractCodeSubValues[code_HoldComplete]:=
 ignoredPatCases[
  code,
  $commonLocalSetHeads,
  Map[
   (HoldPattern[(h:Set|SetDelayed)[spec:(#), v_]]:>
    (SymbolName[Unevaluated@s]->HoldComplete[h[spec, v]]))&,
   NestList[#[___]&, s_Symbol[___][___], 10]
   ]
  ];

(*extractCodeOptions*)
extractCodeOptions[code_HoldComplete]:=
 ignoredPatCases[
  code,
  $commonLocalSetHeads,
  {
   HoldPattern[(h:Set|SetDelayed)[Options[s_Symbol], v_]]:>
   (SymbolName[Unevaluated@s]->HoldComplete[h[Options[s], v]])
   }
  ];

(*extractCodeAttributes*)
extractCodeAttributes[code_HoldComplete]:=
 ignoredPatCases[
  code,
  $commonLocalSetHeads,
  {
   HoldPattern[(h:Set|SetDelayed)[Attributes[s_Symbol], v_]]:>
   (SymbolName[Unevaluated@s]->HoldComplete[h[Attributes[s], v]])
   }
  ];

(*extractCodeParts*)
extractCodeParts[code_HoldComplete]:=
 <|
  "OwnValues"->Association@extractCodeOwnValues[code],
  "DownValues"->Association@extractCodeDownValues[code],
  "UpValues"->Association@extractCodeUpValues[code],
  "SubValues"->Association@extractCodeSubValues[code],
  "Options"->Association@extractCodeOptions[code],
  "Attributes"->Association@extractCodeAttributes[code]
  |>;
extractCodeParts[e_]:=e

(*extractCodePackage*)
extractCodePackage[pkgTag_, codeBlocks:{__String}]:=
 Internal`WithLocalSettings[
  System`Private`NewContextPath[{"System`"}];
  BeginPackage[
   "StackExchangeFunctions`"<>StringDelete[pkgTag, Except[WordCharacter]]<>"`"
   ],
  extractCodeParts@*extractCode/@codeBlocks,
  EndPackage[];
  System`Private`RestoreContextPath[];
  ];

(*validSEConn*)
validSEConn[so_]:=
 ServiceConnections`ServiceInformation[so, "Name"]==="StackExchange";

(*getUserID*)
getUserID[se:_ServiceObject?validSEConn,userName_String]:=
 se["UserIDs", "site"->"mathematica", "inname"->userName][[1]];

(*getQuestions*)
padQuestions[qds_, ids_]:=
 With[
  {
   qqq=
    If[Length@qds<Length@DeleteDuplicates@ids,
     With[{missing=Complement[ids, Normal@qds[All, "question_id"]]},
      SortBy[Position[ids, #["question_id"]&]]@
       Join[
        qds,
        Dataset@
         Map[
          <|
           "title"->"Question "<>ToString@#,
           "question_id"->#,
           "tags"->{},
           "owner"->None
           |>&,
          missing
          ]
        ]
      ],
     qds
     ]
    },
  If[Length@qqq<Length@ids,
   Dataset@Lookup[Map[#["question_id"]->#&, Normal@qqq], Key/@ids],
   qqq
   ]
  ]
getQuestions[se:_ServiceObject?validSEConn,id:{__Integer}]:=
 padQuestions[
  Apply[
   Join,
   Map[
    se["Questions",
     "site"->"mathematica",
     "id"->StringRiffle[ToString/@#, ";"],
     "pagesize"->"100"
     ]&,
    Partition[id, UpTo[100]]
    ]
   ],
  id
  ]

(*getUserAnswers*)
getUserAnswers[
 se:_ServiceObject?validSEConn,
 userID_Integer,
 numAnswers:_Integer|All:100,
 selector:Except[_Integer|All]:None
 ]:=
 Module[
  {sp=
   {
    "site"->"mathematica",
    "id"->ToString@userID,
    "sort"->"votes",
    "filter"->"withbody"
    },
   aBase,
   qBase
   },
  aBase=
   If[IntegerQ@numAnswers&&numAnswers<100,
    se["UserAnswers", Sequence@@sp, "pagesize"->ToString[numAnswers]],
    se["QueryIterate",
     "Request"->"UserAnswers",
     If[IntegerQ@numAnswers,
      "MaxIterations"->Ceiling[numAnswers/100],
      Sequence@@{}
      ],
     Sequence@@sp
     ]
    ];
  qBase=getQuestions[se, Normal@aBase[All, "question_id"]];
  Dataset[
   MapThread[
    Append[KeyDrop[#, {"question_id", "owner"}], "question"->#2]&,
    Normal/@
     {
      aBase,
      qBase
      }
    ]
   ][Replace[selector, {None->All, e_:>Select[selector]}]]
  ];
getUserAnswers[
 se:_ServiceObject?validSEConn,
 userName_String,
 numAnswers:_Integer|All:100 ,
 selector:Except[_Integer|All]:None
 ]:=
 getUserAnswers[se, getUserID[se, userName], numAnswers, selector]

(*getUserAnswerCode*)
getUserAnswerCode[
 userName_String,
 ans_Dataset
 ]:=
 Dataset@
  AssociationThread[
   Normal@ans[All, "question", "title"],
   extractCodePackage[
    userName,
    Normal@ans[All, "body"]
    ]
   ];
getUserAnswerCode[
 se:_ServiceObject?validSEConn,
 userName_String,
 numAnswers:_Integer|All:100,
 selector:Except[_Integer|All]:None
 ]:=
 getUserAnswerCode[
  userName,
  getUserAnswers[se, userName, numAnswers, selector]
  ]
$\endgroup$
  • $\begingroup$ Shouldn't extractCode use InputForm rather than StandardForm so that multiline blocks are parsed properly? $\endgroup$ – lirtosiast Jun 21 at 17:52
  • $\begingroup$ @lirtosiast Probably should? I'm just more used to using StandardForm when interpreting my code and such. $\endgroup$ – b3m2a1 Aug 1 at 0:38

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.