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]
]
