MiscFuncs.m

(* ::Package:: *)

(* Autogenerated Package *)

BeginPackage["MiscFuncs`"];


getCloudObjectDS::usage=
	"Gets cloud objects

https://mathematica.stackexchange.com/questions/170802/how-can-i-spelunk-cloudobjects/170803#170803
";


getFormatImportData::usage="https://mathematica.stackexchange.com/questions/164121/find-import-export-format-data";
getFormatExportData::usage="https://mathematica.stackexchange.com/questions/164121/find-import-export-format-data";


applyPlotTheming::usage="Wraps a graphics function to work better with themes";


myLVP3D::usage="Function for vector plots";


prettyString::usage="";


Begin["`Private`"];


(* ::Subsubsection::Closed:: *)
(*getCloudObjectDS*)



Options[getCloudObjectPath] =
  {
   "Username" -> None
   };
getCloudObjectPath[path_String, ops : OptionsPattern[]] :=

  URLBuild@Flatten@{
     Replace[OptionValue["Username"],
      {
       s_String?(StringLength[#] > 0 &) :>
        "user:" <> StringSplit[s, "@"][[1]],
       _ -> ""
       }
      ],
     URLParse[path, "Path"]
     };
Options[getCloudObjectList] =
  {
   "Iterations" -> None
   };
getCloudObjectList[copath_, ops : OptionsPattern[]] :=

  If[IntegerQ@OptionValue["Iterations"],
   Nest[
    Sort@DeleteDuplicates@
       Flatten[{Map[Quiet@Check[CloudObjects@#, {}] &, #], #}] &, 
    CloudObjects[copath],
    OptionValue["Iterations"]
    ],
   Quiet@Check[CloudObjects@copath, $Failed]
   ];
formatCloudObjectDS[cloudObjData_Association] :=

  Association@
    KeyValueMap[
     StringReplace[First@#, 
        "https://www.wolframcloud.com/objects/" -> "user:"] ->
       Association@Prepend[#2, CloudObject -> #] &,
     cloudObjData
     ] // Dataset;
Options[getCloudObjectDS] =
  Join[
   {
    "CheckPrivate" -> False
    },
   Options[getCloudObjectList],
   Options[getCloudObjectPath]
   ];
getCloudObjectDS[cpath_String, ops : OptionsPattern[]] :=
  Replace[
   getCloudObjectList[
    getCloudObjectPath[cpath, 
     FilterRules[{ops}, Options[getCloudObjectPath]]], 
    FilterRules[{ops}, Options[getCloudObjectList]]
    ],
   l_List :>
    formatCloudObjectDS[
     l // If[TrueQ@OptionValue["CheckPrivate"],
         Map[# -> Quiet@Check[Options[#], $Failed] &],
         Map[# -> {} &]
         ] // Association // Select[Not@*FailureQ]
     ]
   ];
getCloudObjectDS[ops : OptionsPattern[]] :=
 getCloudObjectDS["", ops]


(* ::Subsubsection::Closed:: *)
(*getFormatImportData*)



getFormatImportDataRaw[fmt_] :=

  Block[{$Context = 
     "ItsASecretToEverybody`Private`", $ContextPath = {"System`"}},
   Replace[
    SelectFirst[
     Map[Function @ FileNameJoin @ {#, fmt, "Import.m"},
      System`ConvertersDump`$FormatsDirectory
      ],
     FileExistsQ,
     $Failed
     ],
    s_String :> s -> Import[s, "HeldExpressions"]
    ]
   ];
getFormatImportData[fmt_] :=
 Module[{
   data, 
   file
   },
  data = getFormatImportDataRaw[fmt];
  If[data =!= $Failed,
   {file, data} = List @@ data;
   data /. {
     HoldPattern[Set[s_Symbol, v : _List | _Association]] :>
      RuleCondition[Set[s, v], True]
     };
   With[{cont = 
      FirstCase[data, HoldPattern[Begin[c_]] :> c, 
       "System`FakeHo`", \[Infinity]]},
    SortBy[
       Switch[#[[1]], 
         "FormatName", 0,
         "BinaryFormat", 2,
         "File", 3,
         _, 1
         ] &
       ]@
      Flatten@{
        "DocumentedElements" ->
         FirstCase[data, 
          HoldPattern[
            Set[_Symbol?(Function[Null, 
                SymbolName[Unevaluated@#] == "$DocumentedElements", 
                HoldFirst]), v_]] :> Hold@v,
          None,
          \[Infinity]
          ],
        "HiddenElements" ->
         FirstCase[data, 
          HoldPattern[
            Set[_Symbol?(Function[Null, 
                SymbolName[Unevaluated@#] == "$HiddenElements", 
                HoldFirst]), v_]] :> Hold@v,
          None,
          \[Infinity]
          ],
        FirstCase[data,
         HoldPattern[
           ImportExport`RegisterImport[
            fmtName_, 
            raw_,
            post : _List : {},
            ruls___?System`ConvertersDump`RuleQ
            ]
           ] :>
          {
           "FormatName" -> fmtName,
           Replace[
            Flatten@List@raw,
            {
             (r : Rule | RuleDelayed)[k_, h_] :>
              r[k, h],
             f : Except[_Rule | _RuleDelayed] :> "DefaultImport" -> f
             },
            1
            ],
           Replace[
            post,
            {
             (r : Rule | RuleDelayed)[k_, h_] :>
              r[k, h],
             f : Except[_Rule | _RuleDelayed] :> "DefaultImport" -> f
             },
            1
            ],
           Replace[{ruls},
            ("AvailableElements" -> _Symbol) -> Nothing,
            1
            ],
           "File" -> file
           },
         None,
         \[Infinity]
         ]
        } /. 
     s_Symbol?(Function[Null, 
         Context[#] == "ItsASecretToEverybody`Private`", 
         HoldFirst]) :> 
      RuleCondition[
       ToExpression[cont <> SymbolName[Unevaluated[s]], StandardForm, 
        Inactivate], True]
    ],
   {}
   ]
  ]


(* ::Subsubsection::Closed:: *)
(*getFormatExportData*)



getFormatExportDataRaw[fmt_] := 
  Block[{$Context = 
     "ItsASecretToEverybody`Private`", $ContextPath = {"System`"}}, 
   Replace[
    SelectFirst[
     Map[Function@FileNameJoin@{#, fmt, "Export.m"}, 
      System`ConvertersDump`$FormatsDirectory],
     FileExistsQ, $Failed], 
    s_String :> s -> Import[s, "HeldExpressions"]
    ]
   ];
getFormatExportData[fmt_] :=
 Module[{data, file},
  data = getFormatExportDataRaw[fmt];
  If[data =!= $Failed,
   {file, data} = List @@ data;
   data /. {
     HoldPattern[Set[s_Symbol, v : _List | _Association]] :>
      RuleCondition[Set[s, v], True]
     };
   With[{cont = 
      FirstCase[data, HoldPattern[Begin[c_]] :> c, 
       "System`FakeHo`", \[Infinity]]},
    SortBy[
       Switch[#[[1]], "FormatName", 0, "BinaryFormat", 2, "File", 
         3, _, 1] &
       ]@
      Flatten@{
        "DocumentedElements" ->
         FirstCase[data,
          HoldPattern[
            Set[
             _Symbol?(
               Function[Null,
                SymbolName[Unevaluated@#] == "$DocumentedElements",
                HoldFirst
                ]),
             v_]
            ] :> Hold@v, None, \[Infinity]],
        "HiddenElements" ->
         FirstCase[data,
          HoldPattern[
            Set[
             _Symbol?(
               Function[Null,
                SymbolName[Unevaluated@#] == "$HiddenElements",
                HoldFirst
                ]),
             v_
             ]
            ] :> Hold@v,
          None,
          \[Infinity]],
        FirstCase[data,
         HoldPattern[
           ImportExport`RegisterExport[fmtName_,
            function_,
            ruls___?System`ConvertersDump`RuleQ
            ]
           ] :> {
           "FormatName" -> fmtName,
           "Function" -> function,
           Replace[{ruls},
            ("AvailableElements" -> _Symbol) -> Nothing,
            1],
           "File" -> file
           },
         None,
         \[Infinity]]
        } /. s_Symbol?(
        Function[Null,
         Context[#] == "ItsASecretToEverybody`Private`",
         HoldFirst
         ]
        ) :>
      RuleCondition[
       ToExpression[cont <> SymbolName[Unevaluated[s]],
        StandardForm,
        Inactivate
        ],
       True]
    ],
   {}
   ]
  ]


(* ::Subsubsection::Closed:: *)
(*applyPlotTheming*)



applyPlotTheming[
	coreData_,
	baseFunction_,
	inheritFrom_,
	o:OptionsPattern[]
	]:=
	Module[
		{
			inheritBase=Flatten[{inheritFrom}][[1]],
			theme,
			premethod,
			method,
			defaultstyle,
			defaultcf,
			cf,
			opts,
			threeDFlag,
			ticks
			},
		opts = 
			Flatten @ {o};
		Quiet[
			theme = OptionValue[inheritFrom, opts, PlotTheme]
			];
		theme=Charting`ResolvePlotTheme[theme, inheritBase];
		Quiet[premethod =Quiet@ OptionValue[inheritBase, theme, Method]];
		premethod = Charting`ConstructMethod@ premethod;
		theme = FilterRules[theme, Except @ Method];
		theme =
			FilterRules[
				theme,
				Join@@Map[Options, Flatten[{inheritFrom}]]
				];
		opts = Flatten[{opts, theme}];
		method=Quiet@OptionValue[inheritFrom, opts, Method];
		method=
			Charting`parseMethod[
				Charting`ConstructMethod@method,
				premethod
				];
		{defaultstyle, defaultcf, cf, ticks} =
			Quiet @ 
				OptionValue[
					inheritFrom,
					Flatten @ {method, opts},
					{"DefaultPlotStyle", "DefaultColorFunction", ColorFunction, Ticks}
					];
		cf = Charting`customColorFunction[inheritBase, cf, defaultcf];
		threeDFlag = StringContainsQ[SymbolName[inheritBase], "3D"];
		If[Visualization`Utilities`TicksQ[ticks],
			ticks = 
				If[threeDFlag,
					Visualization`Utilities`TicksExpand3D,
					Visualization`Utilities`TicksExpand
					] @ ticks,
			ticks = 
				If[threeDFlag,
					Visualization`Utilities`TicksExpand3D,
					Visualization`Utilities`TicksExpand
					] @ Automatic
			];
		ticks =
			Visualization`Utilities`ScaleTicks[
				ConstantArray[
					{Identity, Identity},
					If[threeDFlag, 3, 2]
					],
				ticks
				];
		opts=
			Join[
				opts,
				{
					"DefaultPlotStyle"->defaultstyle,
					ColorFunction->cf,
					Ticks->ticks
					}
				];
		baseFunction[
			coreData,
			Charting`FilterGraphicsOptions[
				Flatten@{opts, Method->method},
				Options@baseFunction
				]
			]
		]


(* ::Subsubsection::Closed:: *)
(*customArrows3D*)



Options[customArrows3D]=
	Join[
		Options[ListVectorPlot3D],
		Options[System`VectorPlotsDump`iListVectorPlot3D],
		Charting`$GraphicsExtraOptions
		];
customArrows3D[{coords_, vels_},  ops:OptionsPattern[]]:=
	Module[
		{
			velNorms=Norm/@vels, 
			velMax,
			boxSize=Max@{-(Subtract@@MinMax@CoordinateBounds[coords]), .001},
			defps=OptionValue["DefaultPlotStyle"],
			cf=
				Replace[
					Charting`customColorFunction[
						ListVectorPlot3D,
						OptionValue[VectorColorFunction],
						OptionValue["DefaultColorFunction"]
						],
					cd_ColorDataFunction:>(cd[#]&)
					],
			velVecs,
			ps,
			hackColorMap
			},
		velMax=Max@velNorms;
		ps=
			Charting`customVectorStyle[ 
				OptionValue[VectorStyle],
				defps,
				1
				][[1]];
		If[velMax!=0,
			velVecs=Thread[{coords, coords+vels*(boxSize/10/velMax)}];
			hackColorMap=
			If[cf===None,
				Nothing,
				Association@
					MapThread[
						#[[1]]->(cf@@Flatten[Prepend[##]])&,
						{
							If[OptionValue@VectorColorFunctionScaling,
								Rescale@velVecs,
								velVecs
								],
							If[OptionValue@VectorColorFunctionScaling,
								Rescale@velNorms,
								velNorms
								]
							}
						]
				],
			hackColorMap=
				AssociationMap[Nothing,  cf]
			];
		Show[
			ListPointPlot3D[coords,
				FilterRules[
					Flatten@
						{
							ColorFunctionScaling->
								OptionValue@VectorColorFunctionScaling,
							ColorFunction->
								If[cf=!=None,
									With[{nf=Nearest[Keys@hackColorMap]},
										hackColorMap[nf[{#, #2, #3}][[1]]]&
										],
									cf
									],
							ops,
							PlotStyle->ps,
							BoxRatios->Automatic
							}, 
					Options@ListPointPlot3D
					]
				],
			If[velMax!=0,
				Graphics3D[
					MapThread[
						Flatten@*List,
						{
							Replace[Quiet@OptionValue[VectorScale],
								{
									Automatic:>
										Thread@Arrowheads[velNorms/velMax/25, Appearance->"Projected"],
									n:_?NumericQ:>
										Thread@Arrowheads[n*velNorms/velMax, Appearance->"Projected"],
									_:>
										ConstantArray[
											Arrowheads[Appearance->"Projected"],
											Length@velNorms
											]
									}
								],
							ConstantArray[ps,Length@velNorms],
							If[cf===None,
								Nothing,
								Values@hackColorMap
								],
							Thread[Arrow@velVecs]
							}
						],
					FilterRules[{ops}, Options@Graphics3D]
					]
				],
			{}
			]
		]


(* ::Subsubsection::Closed:: *)
(*myLVP3D*)



myLVP3D[data_, ops:OptionsPattern[]]:=
	applyPlotTheming[
		data,
		customArrows3D,
		{ListVectorPlot3D,System`VectorPlotsDump`iListVectorPlot3D},
		ops
		]


(* ::Subsubsection::Closed:: *)
(*prettyString*)



prettyString[expr_,
   elementsPerLine : _?IntegerQ : 1,
  dataType : TextData | BoxData : BoxData,
  cellStyle : _String : "Input",
  ops : OptionsPattern[Cell]
  ] :=
 StringDelete[
  FrontEndExecute[
    FrontEnd`ExportPacket[
     Cell[
      dataType@
        GeneralUtilities`PrettyFormBoxes[expr, elementsPerLine] /.

           TemplateBox[
         {sym_, ___},
         "DefinitionSymbol", 
         ___
         ] :> sym, 
      cellStyle,
      ops,
      PageWidth -> Infinity
      ],
     "PlainText"
     ]
    ][[1]],
  "\\" ~~ "\n"
  ]


End[];


EndPackage[];