Insurance Justice with Two-Dimensional Underwriting

Seth J. Chandler

University of Houston Law Center, Program on Law and Computation

schandler@uh.edu

http : // www.law.uh.edu/polac

Abstract

Insurers cluster. They generally group insurance applicants with similar perceived risk levels together and offer each group different contracts. This practice, particularly where fine-grained, reduces adverse selection that otherwise prevents desirable trade in risk.  The practice also tends, however, to replicate inequalities in original endowments of risk that may be no fault of the insured.  Coarse classification by contrast, may reduce inequalities resulting from factors that are no fault of the insured but may also result in incomplete risk transfer due to adverse selection.

Hitherto, most scholarship involving regulation of these insurance underwriting practices has considered clustering based on only one-dimension -- perceived risk -- and has correlatively involved offers that vary in only one feature -- price.  This simplification is due in substantial part to the difficulties in modeling more complex clustering and contracting.

This talk looks at how the symbolic and numeric capabilities of Mathematica can collaborate to permit more realistic models of insurance underwriting and thus more realistic appraisals of justice in the regulation of insurance underwriting. It considers “two dimensional underwriting” in which insurers cluster proposed insureds based not only on the perceived level of risk the insured might pose without undertaking risk avoidance but also on the effective price the insured faces to reduce risk. It correlatively considers contracts that vary in two ways: the price charged and the level of care demanded. Particular emphasis is placed on the statistical capabilities advanced in Version 8. The ambition of the project is to generate models that produce results in “real time.”

Why You Should Care

Reason 1: Justice

Theory

A lot of contemporary debate in the United States and elsewhere is about distribution of wealth and income.  Access to insurance markets affects the distribution of income and, in some instances, affects life trajectories.

We can measure distribution of income in a number of ways.  What I want to do here is combine and formalize some ideas of the philosopher John Rawls and the Nobel prize winning economist John Harsanyi and imagine ourselves behind a veil of ignorance where we do not know what sort of person we are going to be when we emerge from behind the veil. We might simply know a distribution of possible persons.  We could evaluate our behind-the-veil position by a single number and thus compare possible distributions if we took a weighted average of the wealth or happiness associated with being each person.  Our weighting function would depend on our risk aversion but it would likely be a function that was non-increasing as we went from being in the worst possible position to the best possible position. In Mathematica terms we could calculate the expected quantile of the distribution with quantiles drawn from a behind-the-veil weighting function that met the following three criteria:

CDF[distribution, 0] == 0

CDF[distribution, 1] == 1

(Subscript[∀, q,0<q≤1])(∂_q)PDF[distribution,q]≤0

This compression of a wealth distribution to a single measure is generally known as a spectral measure.

I claim that the distribution of wealth once we have emerged from the veil is a function of the interaction between the system of insurance regulation ℛ and a number of other factors such as the distribution of risks that individuals pose if they make no effort to reduce them and the distribution of costs that individuals face in an effort to reduce risk.  I will call these other factors ℱ for now.  Thus, in more general terms, if Η is some measure of behind-the-veil risk aversion, my idea is to find the system of insurance underwriting regulation ℛ that maximizes

Expectation[Quantile[distribution[ℛ,ℱ,Η],q],q\[Distributed]behindTheVeilWeightingFunction[Η]]

Example

Reason 2: Mathematica

I have stated the problem at a very abstract level. The ambition is to use Mathematica to make it concrete and computable.  My second ambition is to make this complex system computable in real time.  This is a large multi-factorial system.  Exploring the entire space of possibilities is difficult.  So the faster I can traverse different possibilities such as different degrees of after-veil risk aversion or different classification algorithms adopted by insurers, the more I can get a feel for the factors that make a difference.  I’ve been playing with this problem for a long time and I finally think that with Mathematica 8, I have made some substantial progress. My hope is that even if you work in a field far different from me, there is enough creativity in the use of Mathematica here to make this talk of interest.

The formal idea

Insureds can suffer a loss of ℓ from an insured event.

Insureds have three immutable characteristics

Grid[{{Symbol,"Meaning","Shorthand reference","Domain"},{"f0","probability of an insured event if the insured takes no care","endowed risk","(0,1)"},{"k","responsiveness to care of the probability of the insured event","responsiveness","(0,∞)"},{"ϕ","level of post-veil risk aversion","post-veil risk aversion","[0,1]"}},Dividers->All,Background->{ColorData[42][1],{ColorData[42][2]}},BaseStyle->{FontFamily->"Swiss",FontSize->14}]

Insurers cluster insureds into m categories according to a function of their perception of f0 and k.  The number of categories and methods of clustering may be restricted by law. Each cluster has n[𝒸] people in it where 𝒸 ∈{1..m}.  Insurers offer members of each cluster a contract that has two features: a premium ((Subscript[Π, 𝒸])) and a care condition ((Subscript[Χ, 𝒸])). The premium is defined as an amount per dollar that the insurer will have to pay in the event of an insured event. The care condition means that, if it is determined following an insured event that the insured failed to take Χ precautions, the insurer is excused from an otherwise existing duty to pay the claim. The insurer chooses Χ to be some quantile q of the levels of care the insurer perceives insureds in that cluster would take if there were no insurance available, the idea being to prevent inefficient moral hazard.

Given the contract {Π,Χ} available to members of their cluster, insureds in that cluster then choose a level of insurance (i × ℓ) to purchase and a level of care (x) to take. The law restricts the insured to purchase between (Subscript[i, min]) and (Subscript[i, max]) in insurance.  The insured is assumed to optimize its behavior {(SuperStar[i]),(SuperStar[x])} based on its perception of its immutable characteristics (Subscript[ℱ, d]):((Subscript[f, d]),ϕ,k) and the contract (Subscript[𝒦, 𝒸]):{(Subscript[Π, 𝒸]),(Subscript[Χ, 𝒸])} available to the insured.  Thus, a long form of the ideal contract is

{(SuperStar[i])[(Subscript[ℱ, d]),(Subscript[𝒦, 𝒸])],(SuperStar[x])[(Subscript[ℱ, d]),(Subscript[𝒦, 𝒸])]}

The contract that is offered by the insurer to members of each cluster in turn attempts to be “an equilibrium contract;” one in which, given the {(SuperStar[i]),(SuperStar[x])} choices that would result from the members of the cluster, the insurer would break even.

(Subscript[∀, 𝒸∈{1..m}])(∑_(j=1)^(n[𝒸]))(Subscript[((SuperStar[ℰ])), j])(Subscript[((SuperStar[i])), j])(Subscript[ℓ, j])=(1+λ)(Underoverscript[(Subscript[Π, c])∑, (j=1), n])(Subscript[((SuperStar[i])), j])(Subscript[ℓ, j]), where

(Subscript[((SuperStar[ℰ])), j])=ψ[(Subscript[f0, j]),(Subscript[k, j]),(Subscript[((SuperStar[x])), j])]×θ[Χ,ρ,(Subscript[((SuperStar[x])), j])], where

ρ indicates the error in the system for determining the level of care, ψ determines the probability of an accident and θ determines the probability that the insurer will have to pay (coverage).

We can write this in a more elaborate way, stressing the functional dependencies as

(Subscript[∀, 𝒸∈{1..m}])(∑_(j=1)^(n[𝒸]))(Subscript[((SuperStar[ℰ])[(Subscript[ℱ, d]),(Subscript[𝒦, 𝒸])]), j])(Subscript[((SuperStar[i])[(Subscript[ℱ, d]),(Subscript[𝒦, 𝒸])]), j])(Subscript[ℓ, j])=(1+λ)(Underoverscript[(Subscript[Π, c])∑, (j=1), n])(Subscript[((SuperStar[i])[(Subscript[ℱ, d]),(Subscript[𝒦, 𝒸])]), j])(Subscript[ℓ, j]), where

(Subscript[((SuperStar[ℰ])), j])=ψ[(Subscript[f0, j]),(Subscript[k, j]),(Subscript[((SuperStar[x])[(Subscript[ℱ, d]),(Subscript[𝒦, 𝒸])]), j])]×θ[Χ,ρ,(Subscript[((SuperStar[x])[(Subscript[ℱ, d]),(Subscript[𝒦, 𝒸])]), j])]

An equilibrium contract is found by making a guess as to that contract and then using a hemi-boustrophedonic algorithm to create a dynamic system likely to find such a contract. An auxiliary variable q is used in this process.  The initial guess is based on a user-specified premium (often zero) and a user-specified quantile q0 of the levels of care that would be taken by members of the cluster if there were no insurance. By a hemi-boustrophedonic algorithm I mean one in which, if any member of the cluster is still purchasing insurance the new premium is the exposure weighted average of the expected claims divided by the load augmented total exposure, the new care condition is the same as the old care condition, and (c) the auxiliary variable q remains unchanged.

((Subscript[Π, 𝒸])^(t+1))=(((∑_(j=1)^(n[𝒸]))(Subscript[((SuperStar[ℰ])[(Subscript[ℱ, d]),((Subscript[𝒦, 𝒸])^t)]), j])(Subscript[((((SuperStar[i])[(Subscript[ℱ, d]),(Subscript[𝒦, 𝒸])])^t)), j])(Subscript[ℓ, j]))/((1+λ)(∑_(j=1)^(n[𝒸]))(Subscript[((SuperStar[i])[(Subscript[ℱ, d]),((Subscript[𝒦, 𝒸])^t)]), j])(Subscript[ℓ, j]))), 
(Χ^(t+1))=(Χ^t), and
(q^(t+1))=(q^t)

But if no members of the cluster are still purchasing insurance then the new premium is half the old premium, the new care condition is the q times the (q^th) quantile of the distribution of care taken by insureds on the last iteration and the new value of the auxiliary variable q is the old value multiplied by a constant.

((Subscript[Π, 𝒸])^(t+1))=(((Subscript[Π, 𝒸])^t)/2)
(Χ^(t+1))=Quantile[(Subscript[∀, j∈n[𝒸]])((Subscript[(SuperStar[x])[(Subscript[ℱ, d]),(Subscript[𝒦, 𝒸])], j])^t),q×(q^t)],
(q^(t+1))=q×(q^t)

The Rawls-Harsanyi "behind-the-veil” wealth of society is measured based on the assumption that there is an equal chance of being any person in the insured population and that there is a behind-the-veil level of risk aversion Η. Thus, the behind-the-veil spectral measure of society is the expected quantile of the post-veil spectral measures where the quantile is drawn from some probability distribution reflected behind-the-veil risk aversion.

𝒮=Expectation[Quantile[𝓈,q],q\[Distributed]probabilityDistribution[Η]]

Initialization Code

Reparameterizing the Beta Distribution

Accident Probability and Coverage Probability

Spectral Measure Post-Veil

linearℳ[ϕ_,{f1_,f2_}->{v1_,v2_,v3_}]:=Evaluate[FullSimplify[Expectation[v1 (Boole[0<=q≤f1])+v2 Boole[f1<q≤f1+f2]+v3 Boole[f1+f2<q≤1],q\[Distributed]ProbabilityDistribution[- 2ϕ z + (((2+2ϕ))/2),{z,0,1}]],{0<f1<1,0<f2<1,0<f1+f2<1,0≤ϕ≤1}]];

Insured Behavior Optimization

Solutions via calculus

Insurer Pricing

expectedPayoutsC=Compile[{{𝒫,_Real,2},{Χ,_Real},{ρ,_Real},{λ,_Real},{ℬ,_Real,2}},Module[{pt=𝒫\[Transpose],bt=ℬ\[Transpose],f,ℓ,k,x,i},
f=pt[[1]];
ℓ=pt[[2]];
k=pt[[4]];
i=bt[[1]];
x=bt[[2]];
(1+λ)Total[i*ℓ*Map[Function[y,({{\[Piecewise], ({{((y+ρ-Χ)/(2 ρ)), -ρ+Χ≤y≤ρ+Χ}, {1, y>ρ+Χ}, {0, True}})}})],x] *((f/(1+ k* x)))]],RuntimeAttributes->{Listable},Parallelization->True,CompilationTarget->"C"
];

insurancePurchasedC=Compile[{{𝒫,_Real,2},{ℬ,_Real,2}},
Module[{pt=𝒫\[Transpose],bt=ℬ\[Transpose],ℓ,i},

ℓ=pt[[2]];

i=bt[[1]];

Total[i*ℓ]
],RuntimeAttributes->{Listable},Parallelization->True,CompilationTarget->"C"
];

expectedReceiptsC=Compile[{{𝒫,_Real,2},{ℬ,_Real,2},{Π,_Real}},
Module[{pt=𝒫\[Transpose],bt=ℬ\[Transpose],ℓ,i},

ℓ=pt[[2]];

i=bt[[1]];

Total[i*ℓ*Π]
],RuntimeAttributes->{Listable},Parallelization->True,CompilationTarget->"C"
];

profitC=Compile[{{𝒫,_Real,2},{Χ,_Real},{ρ,_Real},{λ,_Real},{ℬ,_Real,2},{Π,_Real}},expectedReceiptsC[𝒫,ℬ,Π]-expectedPayoutsC[𝒫,Χ,ρ,λ,ℬ],RuntimeAttributes->{Listable},CompilationOptions->{"InlineCompiledFunctions"->True},Parallelization->True,CompilationTarget->"C"]

interpolateRemedy[expectedLosses_]:=Interpolation[Thread[List[Range[0,1,(1/(Length[expectedLosses]-1))],Sort@expectedLosses]],InterpolationOrder->1]

Moving from True Risk to Perceived Risk

Insurance Market Equilibration

Insurance Market Equilibrium with a Semi - Boustrophedonic Algorithm

Spectral Measure Behind the Veil

Population Creation

Insurer Clustering

Culmination

contractTrajectory[𝒫_,{Π_,Χ_,q_},ρ_,λ_,ibounds:{imin_,imax_},ixmFunction_,payoutBasis_,behaviorBasis_,quantileAdjustmentAlgorithmFactory_,quantileAdjustmentParameter_,fixedPointIters_Integer]:=FixedPointList[contractEquilibrateStep[𝒫,#1,ρ,λ,ibounds,ixmFunction,payoutBasis,behaviorBasis,quantileAdjustmentAlgorithmFactory,quantileAdjustmentParameter]&,{Π,Χ,q},fixedPointIters]

contractTrajectoryC[𝒫_,{Π_,Χ_,q_},ρ_,λ_,ibounds:{imin_,imax_},ixmFunction_,payoutBasis_,behaviorBasis_,quantileAdjustmentAlgorithmFactory_,quantileAdjustmentParameter_,fixedPointIters_Integer]:=FixedPointList[contractEquilibrateStepC[𝒫,#1,ρ,λ,ibounds,ixmFunction,payoutBasis,behaviorBasis,quantileAdjustmentAlgorithmFactory,quantileAdjustmentParameter]&,{Π,Χ,q},fixedPointIters]

inits=Table[{RandomReal[{0,1}],RandomReal[{-2,1}],RandomReal[{0,1}]},{500}];

premiumTrajectory[𝒫_,Χ_,ρ_,λ_,ibounds_,ixmFunction_,safetyFunction_,payoutBasis_,behaviorBasis_,initialPremium_,fixedPointIters_]:=FixedPointList[Function[premium,marketEquilibrateStepC[𝒫,Χ,ρ,λ,ibounds,ixmFunction,premium,safetyFunction,payoutBasis,behaviorBasis]],initialPremium,fixedPointIters]

clusteredForContractTrajectory[𝒫_?MatrixQ,{m1_Integer,m2_Integer},Π0_,q0_,ρ_,λ_,ibounds:{imin_,imax_},ixmFunction_,payoutBasis_,behaviorBasis_,quantileAdjustmentAlgorithmFactory_,quantileAdjustmentParameter_]:=Module[{reaped=Reap[clusterByNoInsuranceAccidentProbabilityThenByX[𝒫,Range[Length[𝒫]],{m1,m2}]],clusterIndexArray,sownℬ},
clusterIndexArray=reaped[[1]];
sownℬ=reaped[[2,1,1]];
Map[{Part[𝒫,#1],{Π0,quantileAdjustmentAlgorithmFactory[q0,ρ][Part[sownℬ,#1]],q0},ρ,λ,ibounds,ixmFunction,payoutBasis,behaviorBasis,quantileAdjustmentAlgorithmFactory,quantileAdjustmentParameter}&,clusterIndexArray,{2}]
](*[(Overscript[𝒫, ?×6]),(Overscript[Integer, 2]),"ClusterOutput",(Overscript[f, [(Overscript[ℬ, ?×2])]|->Χ])]|->3 m1 by m2 Arrays. Each element in the first array is a (Overscript[𝒫, 6]).  Each element in the second array is a Χ.  Each element of the third array is a list of integer indices. *)

Visualization

Constants

myRed=RGBColor[0.8156862745098039,0.07058823529411765,0.07058823529411765];

mySeaFoam=RGBColor[0.34901960784313724`,0.5254901960784314,0.5176470588235295];

paletteItem[dimensions_,index:{row_,column_,___}]:=(row-1)*dimensions[[2]]+column

Trajectory View

colorByEndPoint[colorPalette_Integer,endpoints:{{_,_}...}]:=Function[{α,ω,index},Directive[{PointSize[0.03],ColorData[colorPalette][Position[endpoints,Take[ω,2]][[1,1]]]}]]

colorWithoutRegardToEndPoint[colorPalette_Integer,endpoints:{{_,_}...}]:=Function[{α,endpoint,index},Directive[{PointSize[0.01],ColorData[colorPalette][index]}]]

colorLargeWithoutRegardToEndPoint[colorPalette_Integer,endpoints:{{_,_}...}]:=Function[{α,endpoint,index},Directive[{PointSize[0.03],ColorData[colorPalette][index]}]]

trajectoryPrimitives[trajectory_/;MatrixQ[trajectory](* should be n×3*),trajectoryShow_,firstPointDirectiveFunction_,dims_,index:{_Integer,_Integer},colorPalette1_:1,colorPalette2_:2,finalPointColor_:Red,finalPointSize_:0.03,bigPoint_:0.02,mediumPoint_:0.005,invisiblePoint_:0.000001,arrowheadSize_:0.00001]:=
Module[{fpl=Part[trajectory,All,{1,2}],α,ω},

α=First@fpl;
ω=Last@fpl;
{Switch[trajectoryShow,"strong",PointSize[bigPoint],"weak",PointSize[mediumPoint],"none",PointSize[invisiblePoint]],MapIndexed[{ColorData[colorPalette1][paletteItem[dims,index]],Point[#]}&,Most@fpl],
firstPointDirectiveFunction[α,ω,1],Point[α],finalPointColor,PointSize[finalPointSize],Tooltip[Point[Last@fpl],trajectory[[1]]],Directive[{Switch[trajectoryShow,"strong",Thick,"weak",Thin,"none",Thickness[0.00001]],ColorData[colorPalette2][paletteItem[dims,index]]}],Arrowheads[arrowheadSize],Arrow[fpl]}]

trajectoryView[final_,trajectoryShow_,firstPointDirectives_,colorPalette1_,opts___]:=trajectoryView2[Map[#[[2]]&,final,{2}],trajectoryShow,firstPointDirectives,colorPalette1,opts]

trajectoryView2[trajectories_,trajectoryShow_,firstPointDirectives_,colorPalette1_,opts___]:=Module[{dims=Take[Dimensions[trajectories],2],endpoints,colorPalette2},

endpoints=Flatten[Map[Take[Last[#],2]&,trajectories,{2}],1];
colorPalette2=Mod[colorPalette1+1,62,1];Graphics[MapIndexed[Function[{trajectory,outerIndex},trajectoryPrimitives[trajectory,trajectoryShow,Switch[firstPointDirectives,"nothing special",colorWithoutRegardToEndPoint[3,endpoints],"large",colorLargeWithoutRegardToEndPoint[3,endpoints],"large and color by end point",colorByEndPoint[3,endpoints]],dims,outerIndex,colorPalette1,colorPalette2]],trajectories,{2}],opts,AspectRatio->1,PlotRange->{{0,1},{-2,1}},Axes->True,Frame->True,FrameLabel->{"Π","Χ"},BaseStyle->{FontFamily->"Swiss",FontSize->14},ImagePadding->60]]

Traditional View

pointPrimitives[cluster:{𝒫6_,contractTrajectory_,ℬ3_,ρ_,λ_,___},colorPaletteIndex_,dims_,clusterIndex:{row_,column_},f0Basis_,xbasis_,λMultiplyQ_,ybasis_,pointSizeBasis_,pointSizeScale:{pointSizeMin_,pointSizeMax_}]:=
Module[{pi=paletteItem[dims,clusterIndex],𝒫6t=Transpose[𝒫6],ℬ3t=Transpose[ℬ3],f0,ϕ,k,Π,Χ,i,x,ps,ψ,ω,xcoordinate,ycoordinate},
f0=𝒫6t[[Switch[f0Basis,"true",1,"insured",2,"insurer",3]]];
ϕ=𝒫6t[[5]];
k=𝒫6t[[6]];
Π=First[Last[contractTrajectory]];
Χ=Last[contractTrajectory][[2]];
i=ℬ3t[[1]];
x=ℬ3t[[2]];
ψ=CDF[ξ[ρ][Χ],x] (* vector*);
ω=(f0/(1+k x)) (* vector*);
ps=Switch[pointSizeBasis,"insurance",i,"coverage",ψ,"insurance×coverage",i*ψ] (* vector*);
xcoordinate=If[λMultiplyQ,(1+λ),1]*Switch[xbasis,"acc. prob.",ω,"acc. prob. × coverage",ψ*ω];
ycoordinate=Switch[ybasis,"risk aversion",ϕ,"care",x,"insurance",i,"responsiveness",k];
{ColorData[colorPaletteIndex][pi],MapThread[{PointSize[Rescale[#1,{0,1},pointSizeScale]],Point[#2]}&,{ps,Transpose[{xcoordinate,ycoordinate}]}]}]

verticalLinePrimitives[cluster:{𝒫6_,contractTrajectory_,ℬ3_,ρ_,___},colorPaletteIndex_,dims_,clusterIndex:{row_,column_},nonColorDirective_,lineBasis_]:=Module[{pi=paletteItem[dims,clusterIndex],xcoordinate=Switch[lineBasis,"premium",First@Last[contractTrajectory],"mean risk",First@Last[contractTrajectory],"mean expected claim",First@Last[contractTrajectory]]},{nonColorDirective,ColorData[colorPaletteIndex][pi],Line[{{xcoordinate,-2},{xcoordinate,50}}]}
]

horizontalLinePrimitives[cluster:{𝒫6_,contractTrajectory_,ℬ3_,ρ_,___},colorPaletteIndex_,dims_,clusterIndex:{row_,column_},nonColorDirective_,lineBasis_]:=Module[{pi=paletteItem[dims,clusterIndex],ycoordinate=Switch[lineBasis,"condition",Last[contractTrajectory][[2]],"top of coverage ramp",Last[contractTrajectory][[2]]+ρ,"bottom of coverage ramp",Last[contractTrajectory][[2]]-ρ,_,0]},{nonColorDirective,ColorData[colorPaletteIndex][pi],Line[{{0,ycoordinate},{1,ycoordinate}}]}
]

traditionalView[final_,colorPaletteIndex_,{m1_,m2_},f0Basis_,xBasis_,λMultiply_,yBasis_,pointSizeBasis_,pointSizeBounds_,showPremiumLines_,showInsureds_,showConditions_,showCoverageRamps_,yBasis_,{xlow_,xhigh_},{ylow_,yhigh_},opts___Rule]:=Graphics[MapIndexed[{If[showPremiumLines,verticalLinePrimitives[#,colorPaletteIndex,{m1,m2},#2,Directive[{Thick,Dashed}],"premium"],{}],If[showInsureds,pointPrimitives[#,colorPaletteIndex,{m1,m2},#2,f0Basis,xBasis,λMultiply,yBasis,pointSizeBasis,pointSizeBounds],{}],If[showConditions  && yBasis==="care",horizontalLinePrimitives[#,colorPaletteIndex,{m1,m2},#2,Directive[{Thick,Dashed}],"condition"],{}],If[showCoverageRamps && yBasis==="care",horizontalLinePrimitives[#,colorPaletteIndex,{m1,m2},#2,Directive[{Thick,Dotted}],"top of coverage ramp"],{}],If[showCoverageRamps && yBasis==="care",horizontalLinePrimitives[#,colorPaletteIndex,{m1,m2},#2,Directive[{Thick,Dotted}],"bottom of coverage ramp"],{}]}&,final,{2}],Evaluate[Sequence@opts],FrameLabel->{StringJoin[xBasis,If[λMultiply,"\n value multiplied by 1+λ",""]],yBasis},PlotRange->{Sort@{xlow,xhigh},Sort@{ylow,yhigh}},AspectRatio->1,Frame->True,BaseStyle->{FontFamily->"Swiss",FontSize->12},ImageSize->350,ImagePadding->{{60,20},{60,20}}]

Spectral Histogram

Cluster Statistics

clusterColorationFunction[paletteIndex_,dimensions_,index_,indexDimensionsInteractionFunction_]:=ColorData[paletteIndex][indexDimensionsInteractionFunction[dimensions,index]]

RGBToGray[RGBColor[r_,g_,b_]]:=.299r+.587g+.144b;

clusterStatistics[cluster:{𝒫6_,contractTrajectory_,ℬ3_,ρ_,λ_,___},dims_,colorPaletteIndex_,clusterIndex:{row_,column_}]:=
Module[{color=ColorData[colorPaletteIndex][paletteItem[dims,clusterIndex]],𝒫6t=𝒫6\[Transpose],𝒜=Last[contractTrajectory],f0,fr,fd,ℓ,ϕ,k,Π,Χ,q,ℬ3t=ℬ3\[Transpose],i,x,𝓈,trueAccidentProb,insuredAccidentProb,insurerAccidentProb,trueCoverage,stats},

f0=𝒫6t[[1]];
fd=𝒫6t[[2]];
fr=𝒫6t[[3]];
ℓ=𝒫6t[[4]];
ϕ=𝒫6t[[5]];
k=𝒫6t[[6]];
Π=𝒜[[1]];
Χ=𝒜[[2]];
q=𝒜[[3]];
i=ℬ3t[[1]];
x=ℬ3t[[2]];
𝓈=ℬ3t[[3]];
trueAccidentProb=(f0/(1+k x));
insuredAccidentProb=(fd/(1+k x));
insurerAccidentProb=(fr/(1+k x));
trueCoverage=Map[Function[x,({{\[Piecewise], ({{((x+ρ-Χ)/(2 ρ)), -ρ+Χ≤x≤ρ+Χ}, {1, x>ρ+Χ}, {0, True}})}})],x];
stats=Map[Through[{Mean,Sqrt[CentralMoment[#,2]]&}[#]]&,{f0,fd,fr,ℓ,ϕ,k,i,x,𝓈,trueAccidentProb,insuredAccidentProb,insurerAccidentProb,trueCoverage}];

Column[{Grid[{{"population",Length[𝒫6]},{"premium",Π},{"care condition",Χ},{"condition radius",ρ},{"load",λ},{"quantile",q},{"insurer profit","?"}}/.(z_/;(NumericQ[z] && Head[z]===Real)):>NumberForm[z,{5,3}],Dividers->All,Alignment->Left,BaseStyle->{FontFamily->"Swiss",FontSize->12,FontColor->If[RGBToGray[color]<0.5,GrayLevel[1],GrayLevel[0]]},Background->color],

Grid[Prepend[MapThread[Prepend,{stats,{"true risk","insured perceived risk","insurer perceived risk","loss","risk aversion","responsiveness","insurance","care","spectral measure","true accident prob.","insured accident prob.","insurer accident prob.","coverage"}}]/.(z_/;(NumericQ[z] && Head[z]===Real)):>NumberForm[Chop[z],{4,2}],Style[#,{FontSlant->"Italic"}]&/@{"data","mean","st. dev."}],ItemSize->{{14,6,6},1},Dividers->All,Alignment->Left,BaseStyle->{FontFamily->"Swiss",FontSize->12,FontColor->If[RGBToGray[color]<0.5,GrayLevel[1],GrayLevel[0]]},Background->color]}]
]

clusterStatisticsTabView[final_,colorPaletteIndex_,v_]:=TabView[Flatten[MapIndexed[{#2,#2->clusterStatistics[#1,Take[Dimensions[final],2],colorPaletteIndex,#2]}&,final,{2}],1],v]

Grid View

clusterGrid[cluster:{𝒫6_,contractTrajectory_,ℬ3_,ρ_,λ_,___},id_,colorPaletteIndex_,dims_,pickColumns_]:=With[{color=ColorData[colorPaletteIndex][paletteItem[dims,id]]},Labeled[Grid[Part[MapThread[With[{x=#2[[2]],Χ=contractTrajectory[[-1,2]]},Join[{#3},#1,#2,{((#1[[1]])/(1+#1[[6]]*#2[[2]])),({{\[Piecewise], ({{((x+ρ-Χ)/(2 ρ)), -ρ+Χ≤x≤ρ+Χ}, {1, x>ρ+Χ}, {0, True}})}}),((#1[[1]])/(1+#1[[6]]*#2[[2]]))*({{\[Piecewise], ({{((x+ρ-Χ)/(2 ρ)), -ρ+Χ≤x≤ρ+Χ}, {1, x>ρ+Χ}, {0, True}})}})}]]&,{𝒫6,ℬ3,Range[Length[𝒫6]]}],All,pickColumns]/.(z_/;(NumericQ[z] && Head[z]===Real)):>NumberForm[Chop[z],{5,3}],Dividers->All,BaseStyle->{FontFamily->"Swiss",FontSize->9,FontColor->If[RGBToGray[color]<0.5,GrayLevel[1],GrayLevel[0]]},ItemSize->{{{4.5}},1},Background->color],Style[Row[{id,Spacer[18],"Π:",Spacer[3],NumberForm[contractTrajectory[[-1,1]],{5,3}],Spacer[12],"Χ:",Spacer[3],NumberForm[contractTrajectory[[-1,2]],{5,3}],Spacer[12],"q:",Spacer[3],NumberForm[contractTrajectory[[-1,3]],{5,3}]}],{FontFamily->"Swiss",FontSize->11}],Top]]

gridView[final_,colorPaletteIndex_,pickColumns_]:=Column[Prepend[Flatten[MapIndexed[clusterGrid[#1,#2,colorPaletteIndex,Dimensions[final],pickColumns]&,final,{2}]],Grid[{Part[{Tooltip["id","number of individual in cluster"],Tooltip["f0","probability of accident if insured took zero care"],Tooltip["fd","insured's perception of the probability of an accident if insured took zero care"],Tooltip["fr","insurer's perception of the probability of an accident if insured took zero care"],Tooltip["ℓ","size of loss"],Tooltip["ϕ","risk aversion parameter"],Tooltip["k","responsiveness (ability to reduce accident probability)"],Tooltip["i","insurance purchased"],Tooltip["x","care taken"],Tooltip["𝓈","spectral measure"],Tooltip["ψ","accident probability"],Tooltip["θ","coverage probability"],Tooltip["ℰ","accident probability × coverage probability"]},pickColumns]},Dividers->All,BaseStyle->{FontFamily->"Swiss",FontSize->9,FontColor->White},ItemSize->{{{4.5}},1},Background->mySeaFoam]]]

First/@{Tooltip["id","number of individual in cluster"],Tooltip["f0","probability of accident if insured took zero care"],Tooltip["fd","insured's perception of the probability of an accident if insured took zero care"],Tooltip["fr","insurer's perception of the probability of an accident if insured took zero care"],Tooltip["ℓ","size of loss"],Tooltip["ϕ","risk aversion parameter"],Tooltip["k","responsiveness (ability to reduce accident probability)"],Tooltip["i","insurance purchased"],Tooltip["x","care taken"],Tooltip["𝓈","spectral measure"],Tooltip["ψ","accident probability"],Tooltip["θ","coverage probability"],Tooltip["ℰ","accident probability × coverage probability"]}

Raw View

rawView[final_,cluster_]:=final[[cluster]];

Manipulates

individualManipulateControls={Pane[OpenerView[{"insured attributes",
Column[{Control@{{f,0.1,"f0"},0.01,1,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ℓ,3,"loss (ℓ)"},1,10,1,Appearance->"Labeled",ImageSize->Small},
Control@{{ϕ,0.5,"risk aversion (ϕ)"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{k,5,"responsiveness (k)"},0,50,1,Appearance->"Labeled",ImageSize->Small}}
]}],366],
Delimiter,
Pane[OpenerView[{"contract parameters",
Column[{Control@{{Π,0.022,"premium rate (Π)"},0.01,0.2,0.001,Appearance->"Labeled",ImageSize->Small},
Control@{{Χ,.25,"care condition (Χ)"},-1,1,0.01,Appearance->"Labeled",ImageSize->Small}}
]}],366],
Delimiter,
Pane[OpenerView[{"regulatory system",
Column[{Control@{{ρ,0.07,"condition radius (ρ)"},0.01,0.5,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{imin,0,"min. ins. ((Subscript[i, min]))"},0,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{iδ,1,"max. ins. ((Subscript[i, max]))"},0.1,1,0.01,Appearance->"Labeled",ImageSize->Small}}
]}],366],
Delimiter,
Pane[OpenerView[{"visualization controls",
Column[{Control@{{maxcare,1,"max care"},0,1,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{surfaceMesh,None,"surface mesh"},{None,Automatic}},
Control@{{mf,{#1&,#2&},"mesh function"},{{#1&,#2&}->"normal",{#3&}->"contour"}},
Control@{{showLosingCandidates,False,"show losing candidates"},{True,False}},
Control@{{showConditionPlanes,True,"show condition planes"},{True,False}},
Control@{{onlyextremes,False,"insurance extremes only"},{True,False}},
Control@{{extremeradius,0.01,"extreme visualization radius"},0.01,0.04,0.01,ImageSize->Small,Enabled->onlyextremes},
Control@{{viewpoint,{1.3,-2.4,2},"viewpoint"},{{1.3,-2.4,2},Above,Below,Front,Back,Left,Right},ControlType->PopupMenu}}
]}],366],ControlPlacement->Left,LabelStyle->14};

individualManipulate[extremeradius_,f_,imin_,iδ_,k_,maxcare_,mf_,onlyextremes_,showConditionPlanes_,showLosingCandidates_,surfaceMesh_,viewpoint_,ℓ_,Π_,ρ_,ϕ_,Χ_]:=Module[{imax$=Min[imin+iδ,1],opt$,is$},opt$=optimalSolutionC[{f,ℓ,ϕ,k},{Π,Χ},ρ,{imin,imax$}];is$=400;Column[{Show[Plot3D[optFunctionC[{f,ℓ,ϕ,k},{Π,Χ},ρ,{i,x}],{i,imin,imax$},{x,0.`,maxcare},ViewPoint->viewpoint,ColorFunction->({Opacity[0.6`],ColorData["Rainbow"][#]}&),AxesLabel->{"i","x","𝓈"},Mesh->surfaceMesh,MeshFunctions->mf,Boxed->False,AxesStyle->Thickness[Medium],RegionFunction:>If[onlyextremes,Function[{x$,y$,z$},imin-extremeradius<x$<imin+extremeradius||imax$-extremeradius<x$<imax$+extremeradius],True&],LabelStyle->{FontFamily->"Swiss",FontSize->14},ImageSize->is$,ImagePadding->{{60,20},{60,20}}],Graphics3D[{PointSize[0.02`],If[showLosingCandidates,Point[candidateSolutionsC[{f,ℓ,ϕ,k},{Π,Χ},ρ,{imin,imax$}]],{}],mySeaFoam,PointSize[0.04`],Point[opt$]}],If[showConditionPlanes,ParametricPlot3D[{{i,Χ,𝓈},{i,Χ+ρ,𝓈},{i,Χ-ρ,𝓈}},{i,0,1},{𝓈,-3,3},PlotStyle->{Opacity[0.5`],Opacity[0.25`],Opacity[0.25`]},PlotPoints->2,Mesh->None],{}],If[showConditionPlanes,Graphics3D[{Text["Χ",{1,Χ,-1}],Text["Χ+ρ",{1,Χ+ρ,-0.8`}],Text["Χ-ρ",{1,Χ-ρ,-0.6`}]}],Graphics3D[{}]]],Grid[{{"optimal\nins.\n(SuperStar[x])","optimal\ncare\n(SuperStar[i])","(SuperStar[𝓈])","accident\nprob.\n(SuperStar[ψ])","coverage\nprob.\n(SuperStar[θ])","expected\npayout\n(SuperStar[ℰ])"},{opt$[[1]],opt$[[2]],opt$[[3]],(f/(1+k opt$[[2]])),If[opt$[[1]]==0.`,"N/A",CDF[ξ[ρ][Χ],opt$[[2]]]],((((opt$[[1]] ℓ) f) CDF[ξ[ρ][Χ],opt$[[2]]])/(1+k opt$[[2]]))}}/.x_?NumericQ:>NumberForm[x,{5,3}],Dividers->All,Background->{None,{myRed,mySeaFoam}},BaseStyle->{LineIndent->0,FontFamily->"Swiss",FontSize->14,FontColor->White}]}]];

populationGenerationControls={Column[{Style["population parameters",14,FontSlant->"Italic"],Control@{{popSize,20,"population size (n)"},5,200,5,Appearance->"Labeled",ImageSize->Small},
Control@{{μ,0.2,"mean f0 (μ)"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ϵ,0.1,"f0 dispersion (ϵ)"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ℓ,1,"loss (ℓ}"},1,10,0.1,Appearance->"Labeled",ImageSize->Small},
Control@{{ϕμ,0.5,"mean risk aversion (ϕμ)"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ϕϵ,0.1,"risk aversion dispersion (ϕϵ)"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{kmax,20,"maximum resp. ((Subscript[k, max]))"},0.1,50,0.1,Appearance->"Labeled",ImageSize->Small},
Control@{{kμ,0.5,"mean/max. resp. (kμ)"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{kϵ,0.1,"resp. dispersion (kϵ)"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insuredBias,0,"insured bias (d𝒷)"},-0.9,0.9,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insuredDispersion,0.01,"insured dispersion (dϵ)"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insurerBias,0,"insurer bias (r𝒷)"},-0.9,0.9,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insurerDispersion,0.01,"insurer dispersion (rϵ)"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small}}],
Delimiter,

Style["visualization",14,FontSlant->"Italic"],
Control@{{populationVisualization,"Grid","population visualization"},{"Grid","Histogram","Histogram3D","ListPlot","ListPointPlot3D"},ControlType->PopupMenu},

PaneSelector[{"Grid"->"",
"Histogram"->Control@{{characteristic,"fα","characteristic"},Thread[Rule[{"fα","fd","fr","ℓ","ϕ","k"},{"true risk (fα)","insured perceived risk (fd)","insurer perceived risk (fr)","loss (ℓ)","risk aversion (ϕ)","responsiveness (k)"}]]},
"Histogram3D"->Column[{Control@{{xcharacteristic,"fα","x-characteristic"},Thread[Rule[{"fα","fd","fr","ℓ","ϕ","k"},{"true risk (fα)","insured perceived risk (fd)","insurer perceived risk (fr)","loss (ℓ)","risk aversion (ϕ)","responsiveness (k)"}]]},Spacer[24],Control@{{ycharacteristic,"fα","y-characteristic"},Thread[Rule[{"fα","fd","fr","ℓ","ϕ","k"},{"true risk (fα)","insured perceived risk (fd)","insurer perceived risk (fr)","loss (ℓ)","risk aversion (ϕ)","responsiveness (k)"}]]}}],
"ListPlot"->Column[{Control@{{xcharacteristic,"fα","x-characteristic"},Thread[Rule[{"fα","fd","fr","ℓ","ϕ","k"},{"true risk (fα)","insured perceived risk (fd)","insurer perceived risk (fr)","loss (ℓ)","risk aversion (ϕ)","responsiveness (k)"}]]},Spacer[24],Control@{{ycharacteristic,"fα","y-characteristic"},Thread[Rule[{"fα","fd","fr","ℓ","ϕ","k"},{"true risk (fα)","insured perceived risk (fd)","insurer perceived risk (fr)","loss (ℓ)","risk aversion (ϕ)","responsiveness (k)"}]]}}],
"ListPointPlot3D"->Column[{Control@{{xcharacteristic,"fα","x-characteristic"},Thread[Rule[{"fα","fd","fr","ℓ","ϕ","k"},{"true risk (fα)","insured perceived risk (fd)","insurer perceived risk (fr)","loss (ℓ)","risk aversion (ϕ)","responsiveness (k)"}]]},Spacer[24],Control@{{ycharacteristic,"fα","y-characteristic"},Thread[Rule[{"fα","fd","fr","ℓ","ϕ","k"},{"true risk (fα)","insured perceived risk (fd)","insurer perceived risk (fr)","loss (ℓ)","risk aversion (ϕ)","responsiveness (k)"}]]},Spacer[24],Control@{{zcharacteristic,"fα","z-characteristic"},Thread[Rule[{"fα","fd","fr","ℓ","ϕ","k"},{"true risk (fα)","insured perceived risk (fd)","insurer perceived risk (fr)","loss (ℓ)","risk aversion (ϕ)","responsiveness (k)"}]]}}]},Dynamic[populationVisualization]],
ControlPlacement->Left,LabelStyle->{FontSize->12,FontFamily->"Swiss",myRed}};

condensedPopulationControls={Row[{Column[{Control@{{popSize,20,"population size"},5,200,5,Appearance->"Labeled",ImageSize->Small},
Control@{{μ,0.2,"mean f0"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ϵ,0.1,"f0 disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ℓ,1,"loss"},1,10,0.1,Appearance->"Labeled",ImageSize->Small}}],
Column[{Control@{{ϕμ,0.5,"mean risk aversion"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ϕϵ,0.1,"risk aversion disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{kmax,20,"maximum resp."},0.1,50,0.1,Appearance->"Labeled",ImageSize->Small},
Control@{{kμ,0.5,"mean/max. resp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},Control@{{kϵ,0.1,"resp. disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small}}],
Column[{
Control@{{insuredBias,0,"insured bias"},-0.9,0.9,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insuredDispersion,0.01,"insured disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insurerBias,0,"insurer bias"},-0.9,0.9,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insurerDispersion,0.01,"insurer disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small}}]}],
ControlPlacement->Top,LabelStyle->{FontSize->12,FontFamily->"Swiss",myRed}};

insuranceSystem[clusterStatisticsPalette_,f0Basis_,firstPointDirectives_,fpiters_,histogramLayout_,histogramPalette_,imax_,imin_,loadBasis_,m1_,m2_,pointSizeBasis_,q0Control_,quantileAdjustmentFactor_,safetyQuantile_,showConditions_,showCoverageRamps_,showInsureds_,showPremiumLines_,show𝒮_,tab_,trajectoryColorPalette_,trajectoryShow_,v1_,v2_,xBasis_,xhighControl_,xlowControl_,yBasis_,yhighControl_,ylowControl_,Η_,λ0_,λcc_,λdirect_,λMultiply_,λρ_,Π0_,ρ_]:=
Module[{λ$=Switch[loadBasis,
"direct",λdirect,
"parametric",λ0+λcc (m1 m2-1)+λρ ρ],q0$=Round[Rescale[q0Control,{0,1},{0.01`,1}],0.01`],is$={365,408},ps$={380,460},cfct$,ct$,stage2$,final$,Χ$,pts$,linePrims$},cfct$=clusteredForContractTrajectory[𝒫,{m1,m2},Π0,q0$,ρ,λ$,{imin,imax},ixmStandardC,truePerceptionMatrixC,insuredPerceptionMatrixC,makeΧ,quantileAdjustmentFactor];ct$=Map[contractTrajectory[Sequence@@#1,fpiters]&,cfct$,{2}];stage2$=MapThread[ReplacePart[#1,2->#2]&,{cfct$,ct$},2];final$=Map[Function[cluster$,Insert[cluster$,(optimalSolutionC[#1[[{1,4,5,6}]],Take[Last[cluster$[[2]]],2],ρ,{imin,imax}]&)/@First[cluster$],3]],stage2$,{2}];
Pane[Labeled[Switch[tab,
"traditional",Module[{xlow$=xlowControl,xhigh$=xhighControl,ybounds$=Switch[yBasis,
"risk aversion",{0,1},
"care",{0,2},
"insurance",{0,1},
"responsiveness",{0,50}],ylow$,yhigh$},ylow$=Rescale[ylowControl,{0,1},ybounds$];yhigh$=Rescale[yhighControl,{0,1},ybounds$];traditionalView[final$,61,{m1,m2},f0Basis,xBasis,λMultiply,yBasis,pointSizeBasis,{0.005`,0.02`},showPremiumLines,showInsureds,showConditions,showCoverageRamps,yBasis,{xlow$,xhigh$},{ylow$,yhigh$}]],
"cluster statistics",clusterStatisticsTabView[final$,clusterStatisticsPalette,{v1,v2}],
"histogram",spectralHistogramVisualization[final$,Η,ChartLayout->histogramLayout,ChartStyle->Flatten[{myRed,mySeaFoam,Table[ColorData[histogramPalette][i],{i,1,10}],Table[ColorData[Mod[histogramPalette+1,62,1]][i],{i,1,10}]}]],
"grid",gridView[final$,61,pickColumns],
"trajectory",trajectoryView[final$,trajectoryShow,firstPointDirectives,trajectoryColorPalette,PlotRange->Module[{xlow$=xlowControl,xhigh$=xhighControl,ybounds$={-1,2},ylow$,yhigh$},ylow$=Rescale[ylowControl,{0,1},ybounds$];yhigh$=Rescale[yhighControl,{0,1},ybounds$];{{xlow$,xhigh$},{ylow$,yhigh$}}],ImageSize->300],
"raw",rawView[final$,{v1,v2}]],If[show𝒮,Style[Row[{"𝒮:",Spacer[6],With[{u=Map[Last/@#[[3]]&,final$,{2}]},𝒮[Η,Flatten[u]]]}],{FontFamily->"Swiss",FontSize->14,FontWeight->"Bold"}],""],Bottom],ps$,Scrollbars->{True,True}]]

An insured’s demand for insurance and care

Manipulate[individualManipulate[extremeradius,f,imin,iδ,k,maxcare,mf,onlyextremes,showConditionPlanes,showLosingCandidates,surfaceMesh,viewpoint,ℓ,Π,ρ,ϕ,Χ],
Evaluate@(Sequence@@individualManipulateControls)]

The Mathematica behind the “insured’s demand” Manipulate

Surface function (a “spectral measure”) found by taking the expected quantile of a slight tweaking of a symbolic EmpiricalDistribution object weighted by a custom parameterized ProbabilityDistribution object

Surface generated using Compile[..., CompilationTarget -> "C"]

Candidates for optimum found by using Mathematica to:

differentiate surface function with respect to insurance purchased (i) and confirm that it is linear.  Thus, solution must lie on (Subscript[i, min]) or (Subscript[i, max])

FreeQ[FullSimplify[D[optFunction[{f,ℓ,ϕ,k},{Π,Χ},ρ,{i,x}],i]],i]

find families of a custom parameterized ProbabilityDistribution object which, when used to generate a surface function via the expected quantile, have a derivative in x whose roots can be computed as a closed form expression

Solve[{ϕ >= 0, ℓ > 0, f > 0, 0 <= i <= 1, k >= 0, 0 == Refine[dopt1, x < -ρ + Χ], 0 > Refine[dopt2, x < -ρ + Χ]}, x, Reals]

(3) Use Mathematica' s Algebraic solvers to go from Root objects involving third degree polynomials, numeric computation of which can take a bit of time, to compilable closed forms (I wish Mathematica could do this on its own or I was smart enough to know how to do this in Mathematica)

Create Listable and Parallelized functions with CompilationTarget -> "C" to identify and evaluate combinations of {i, x} that could be maxima

Create visualizations with standard plotting commands and a little graphics programming at the Tom Wickham - Jones 1994 level

Construct an interface using basic Manipulate arguments

Notice use of one line first argument to Manipulate

Notice use of Pane[OpenerView[{heading, Column[{ ...}]}], 366] to keep things compact and tidy

Creating a population of insureds

Manipulate[Row[{Pane[{
Dynamic[fδ=RandomVariate[scaledBetaDistribution[μ,ϵ],{popSize}],TrackedSymbols :> {popSize,μ,ϵ}],
Dynamic[ℓδ=RandomVariate[TransformedDistribution[ℓ loss,loss\[Distributed]BernoulliDistribution[1]],{popSize}],TrackedSymbols:>{popSize,ℓ}],
Dynamic[ϕδ=RandomVariate[scaledBetaDistribution[ϕμ,ϕϵ],{popSize}],TrackedSymbols:>{popSize,ϕμ,ϕϵ}],
Dynamic[kδ=RandomVariate[TransformedDistribution[kmax b,b\[Distributed]scaledBetaDistribution[kμ,kϵ]],{popSize}],TrackedSymbols:>{popSize,kmax,kμ,kϵ}],
Dynamic[fdδ=Map[RandomVariate[perceptionDistribution[#,insuredBias,insuredDispersion]]&,fδ],TrackedSymbols:>{popSize,fδ,μ,ϵ,insuredBias,insuredDispersion}],
Dynamic[frδ=Map[RandomVariate[perceptionDistribution[#,insurerBias,insurerDispersion]]&,fδ],TrackedSymbols:>{popSize,fδ,μ,ϵ,insurerBias,insurerDispersion}],
Dynamic[𝒫=Transpose[{fδ,fdδ,frδ,ℓδ,ϕδ,kδ}]]
}, ImageSize -> {1,1},BaseStyle -> ShowContents -> False],Dynamic@Pane[Module[{characteristicToIndex={"fα"->1,"fd"->2,"fr"->3,"ℓ"->4,"ϕ"->5,"k"->6},minRules={"fα"->0,"fd"->0,"fr"->0,"ℓ"->0,"ϕ"->0,"k"->0},
maxRules={"fα"->1,"fd"->1,"fr"->1,"ℓ"->10,"ϕ"->1,"k"->50},cosmetics={ImageSize->{400,400},ImagePadding->{{60,10},{60,10}},BaseStyle->{FontFamily->"Swiss",FontSize->12}},
cosmetics2D,cosmeticsHistogram,cosmetics3D,cosmeticsHistogram3D},
cosmetics2D={Axes->False,Frame->True,FrameLabel->{xcharacteristic,ycharacteristic},PlotRange->{Map[Rescale[#,{0,1},{xcharacteristic/.minRules,xcharacteristic/.maxRules}]&,{0,1}],Map[Rescale[#,{0,1},{ycharacteristic/.minRules,ycharacteristic/.maxRules}]&,{0,1}]}};
cosmeticsHistogram={Axes->False,Frame->True,FrameLabel->{characteristic,"Count"}};
cosmeticsHistogram3D={AxesLabel->{xcharacteristic,ycharacteristic,"Count"}};
cosmetics3D=FilterRules[{PlotStyle->PointSize[0.02],PlotRange->{Map[Rescale[#,{0,1},{xcharacteristic/.minRules,xcharacteristic/.maxRules}]&,{0,1}],Map[Rescale[#,{0,1},{ycharacteristic/.minRules,ycharacteristic/.maxRules}]&,{0,1}],Map[Rescale[#,{0,1},{zcharacteristic/.minRules,zcharacteristic/.maxRules}]&,{0,1}]},AxesLabel->{xcharacteristic,ycharacteristic,zcharacteristic}},Options[Switch[populationVisualization,"Histogram",Histogram,"Histogram3D",Histogram3D,"ListPlot",ListPlot,"ListPointPlot3D",ListPointPlot3D]]];
Switch[populationVisualization,"Grid",Grid[Join[{{"true risk","insured perceived risk","insurer perceived risk","loss","risk aversion","responsiveness"},{"fα","fd","fr","ℓ","ϕ","k"}},𝒫]/.x_Real?NumericQ:>NumberForm[x,{5,3}],BaseStyle->{LineIndent->0,FontFamily->"Swiss",FontSize->12,FontColor->White},Dividers->All,Alignment->Left,Background->With[{palette=35},{None,{(*ColorData[palette][5],ColorData[palette][1],*)myRed,mySeaFoam,{ColorData[palette][5],ColorData[palette][6]}}}],ItemSize->{{6.,6.,6.,3.3,6.,6.},1}],"Histogram",Histogram[Part[𝒫,All,characteristic/.characteristicToIndex],Evaluate[Sequence@@cosmetics],Evaluate[Sequence@@cosmeticsHistogram]],"Histogram3D",Histogram3D[Part[𝒫,All,{xcharacteristic,ycharacteristic}/.characteristicToIndex],Evaluate[Sequence@@cosmetics],Evaluate[Sequence@@cosmeticsHistogram3D]],"ListPlot",ListPlot[Part[𝒫,All,{xcharacteristic,ycharacteristic}/.characteristicToIndex],Evaluate[Sequence@@cosmetics],Evaluate[Sequence@@cosmetics2D]],"ListPointPlot3D",ListPointPlot3D[Part[𝒫,All,{xcharacteristic,ycharacteristic,zcharacteristic}/.characteristicToIndex],Evaluate[Sequence@@cosmetics],Evaluate[Sequence@@cosmetics3D]]]],{425,400},Scrollbars->{True,True}]}],
Evaluate@(Sequence@@populationGenerationControls)]

The Mathematica behind the population creation Manipulate

Use of custom and reparameterized distributions

The Pane trick to deal with multiple calls to RandomVariate

PaneSelector in the controls area for context - sensitive controls

Equilibrating a Contract: Implementing a Dynamic System

Labeled[Manipulate[Column[{Pane[{
Dynamic[fδ=RandomVariate[scaledBetaDistribution[μ,ϵ],{popSize}],TrackedSymbols :> {popSize,μ,ϵ}],
Dynamic[ℓδ=RandomVariate[TransformedDistribution[ℓ loss,loss\[Distributed]BernoulliDistribution[1]],{popSize}],TrackedSymbols:>{popSize,ℓ}],
Dynamic[ϕδ=RandomVariate[scaledBetaDistribution[ϕμ,ϕϵ],{popSize}],TrackedSymbols:>{popSize,ϕμ,ϕϵ}],
Dynamic[kδ=RandomVariate[TransformedDistribution[kmax b,b\[Distributed]scaledBetaDistribution[kμ,kϵ]],{popSize}],TrackedSymbols:>{popSize,kmax,kμ,kϵ}],
Dynamic[fdδ=Map[RandomVariate[perceptionDistribution[#,insuredBias,insuredDispersion]]&,fδ],TrackedSymbols:>{popSize,fδ,μ,ϵ,insuredBias,insuredDispersion}],
Dynamic[frδ=Map[RandomVariate[perceptionDistribution[#,insurerBias,insurerDispersion]]&,fδ],TrackedSymbols:>{popSize,fδ,μ,ϵ,insurerBias,insurerDispersion}],
Dynamic[𝒫=Transpose[{fδ,fdδ,frδ,ℓδ,ϕδ,kδ}]]
}, ImageSize -> {1,1},BaseStyle -> ShowContents -> False],
Grid[{{"n","μ","ϵ","ℓ","ϕμ","ϕϵ","kmax","kμ","kϵ","d𝒷","dϵ","r𝒷","rϵ"},
{popSize,μ,ϵ,ℓ,ϕμ,ϕϵ,kmax,kμ,kϵ,insuredBias,insuredDispersion,insurerBias,insurerDispersion}},BaseStyle->{LineIndent->0,FontFamily->"Swiss",FontSize->12,FontColor->White},Dividers->All,Alignment->Left,Background->With[{palette=35},{None,{myRed,mySeaFoam,{ColorData[palette][5],ColorData[palette][6]}}}],ItemSize->{Table[4.8,{13}],1}]}],
Evaluate@(Sequence@@condensedPopulationControls)],Style["Condensed Population Adjuster",{FontSize->16,FontFamily->"Swiss",mySeaFoam}],Top]

Manipulate[Module[{Π=First[ΠΧ],Χ=Last[ΠΧ],trajectoryArray},
trajectoryArray=Map[contractTrajectoryC[𝒫,#,ρ,λ,{imin,imax},ixmStandardC,truePerceptionMatrixC,insuredPerceptionMatrixC,makeΧ,qShrink,fpIters]&,{{{Π,Χ,q}}},{2}];
trajectoryView2[trajectoryArray,trajectoryShow,"nothing special",35,PlotRange->{{0,1},{-2,1}},ImageSize->400]],
(* controls *)
Style["large black dot is a locator object; move it",10],
{{ΠΧ,{0,-1}},{0,-2},{1,1},{0.01,0.01},Locator,Appearance->None},
{{q,0.1,"adjustment parameter"},0.1,0.9,0.01,Appearance->"Labeled"},{{ρ,0.1,"condition radius"},0.01,0.3,0.01,Appearance->"Labeled"},
{{λ,0,"load"},-0.5,1,0.01,Appearance->"Labeled"},
{{imin,0,"minimum insurance"},0,1,0.01,Appearance->"Labeled"},
{{imax,1,"maximum insurance"},0.1,1,0.01,Appearance->"Labeled"},
{{qShrink,0.9,"shrink q factor"},0.1,0.99,0.01,Appearance->"Labeled"},
{{fpIters,20,"maximum iterations"},0,20,1,Appearance->"Labeled"},
{{trajectoryShow,"strong","show trajectory how?"},{"strong","weak","none"}},
LabelStyle->{FontSize->12,FontFamily->"Swiss",myRed},ControlPlacement->Left]

Manipulate[
Module[{starts3d=MapThread[Append,{starts2d,Last/@Take[inits,Length[starts2d]]}],trajectoryArray},
trajectoryArray=Map[contractTrajectoryC[𝒫,#,ρ,λ,{imin,imax},ixmStandardC,truePerceptionMatrixC,insuredPerceptionMatrixC,makeΧ,qShrink,fpIters]&,{starts3d},{2}];
trajectoryView2[trajectoryArray,trajectoryShow,firstPointDirectives,35,PlotRange->{{0,1},{-2,1}},ImageSize->400]
],

(* -----Controls ----- *)
Style["inital points are Locators with LocatorAutoCreate->True;\nmove them, create them, delete them",10],
{{ρ,0.1,"condition radius"},0.01,0.3,0.01,Appearance->"Labeled"},{{λ,0,"load"},-0.5,1,0.01,Appearance->"Labeled"},
{{imin,0,"minimum insurance"},0,1,0.01,Appearance->"Labeled"},
{{imax,1,"maximum insurance"},0.1,1,0.01,Appearance->"Labeled"},
{{qShrink,0.9,"shrink q factor"},0.1,0.99,0.01,Appearance->"Labeled"},
{{fpIters,20,"maximum iterations"},0,20,1,Appearance->"Labeled"},
{{trajectoryShow,"strong","show trajectory how?"},{"strong","weak","none"}},
{{firstPointDirectives,"nothing special","initialization directive"},{"nothing special","large","large and color by end point"},ControlType->PopupMenu},
{{starts2d,Take[inits,10,2]},{0,-2},{1,1},{0.01,0.01},Locator,LocatorAutoCreate->True,Appearance->None},
LabelStyle->{FontSize->12,FontFamily->"Swiss",myRed},ControlPlacement->Left,SynchronousUpdating->False]

The Mathematica behind Contract Equilibration

In general, just adjust the premium to the value which, if care remained unchanged, would cause the insurer to just break even.  If, however, the system "blows up,” search {Π,Χ} space through a hemi-boustrophedonic algorithm in which the premium is cut in half, the care condition is adjusted to a user-specified fraction of the current quantile of the existing distribution of care, and the current quantile is adjusted to a user-specified fraction of the current quantile

Programming idea similar to that in many New Kind of Science dynamical systems

use an uncompiled function for each iteration

or a compiled function for each iteration

then use FixedPointList with either an uncompiled or compiled function as the first argument

Basic graphics programming to convert the output of FixedPointList into a meaningful graphic

Manipulate features

Use of Locator object to set initial premium (s) and care condition (s)

Looking at an Insurance System

Recapitulating population creation

Labeled[Manipulate[Column[{Pane[{
Dynamic[fδ=RandomVariate[scaledBetaDistribution[μ,ϵ],{popSize}],TrackedSymbols :> {popSize,μ,ϵ}],
Dynamic[ℓδ=RandomVariate[TransformedDistribution[ℓ loss,loss\[Distributed]BernoulliDistribution[1]],{popSize}],TrackedSymbols:>{popSize,ℓ}],
Dynamic[ϕδ=RandomVariate[scaledBetaDistribution[ϕμ,ϕϵ],{popSize}],TrackedSymbols:>{popSize,ϕμ,ϕϵ}],
Dynamic[kδ=RandomVariate[TransformedDistribution[kmax b,b\[Distributed]scaledBetaDistribution[kμ,kϵ]],{popSize}],TrackedSymbols:>{popSize,kmax,kμ,kϵ}],
Dynamic[fdδ=Map[RandomVariate[perceptionDistribution[#,insuredBias,insuredDispersion]]&,fδ],TrackedSymbols:>{popSize,fδ,μ,ϵ,insuredBias,insuredDispersion}],
Dynamic[frδ=Map[RandomVariate[perceptionDistribution[#,insurerBias,insurerDispersion]]&,fδ],TrackedSymbols:>{popSize,fδ,μ,ϵ,insurerBias,insurerDispersion}],
Dynamic[𝒫=Transpose[{fδ,fdδ,frδ,ℓδ,ϕδ,kδ}]]
}, ImageSize -> {1,1},BaseStyle -> ShowContents -> False],
Grid[{{"n","μ","ϵ","ℓ","ϕμ","ϕϵ","kmax","kμ","kϵ","d𝒷","dϵ","r𝒷","rϵ"},
{popSize,μ,ϵ,ℓ,ϕμ,ϕϵ,kmax,kμ,kϵ,insuredBias,insuredDispersion,insurerBias,insurerDispersion}},BaseStyle->{LineIndent->0,FontFamily->"Swiss",FontSize->12,FontColor->White},Dividers->All,Alignment->Left,Background->With[{palette=35},{None,{myRed,mySeaFoam,{ColorData[palette][5],ColorData[palette][6]}}}],ItemSize->{Table[4.8,{13}],1}]}],
Row[{Column[{Control@{{popSize,20,"population size"},5,200,5,Appearance->"Labeled",ImageSize->Small},
Control@{{μ,0.2,"mean f0"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ϵ,0.1,"f0 disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ℓ,1,"loss"},1,10,0.1,Appearance->"Labeled",ImageSize->Small}}],
Column[{Control@{{ϕμ,0.5,"mean risk aversion"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{ϕϵ,0.1,"risk aversion disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{kmax,20,"maximum resp."},0.1,50,0.1,Appearance->"Labeled",ImageSize->Small},
Control@{{kμ,0.5,"mean/max. resp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},Control@{{kϵ,0.1,"resp. disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small}}],
Column[{
Control@{{insuredBias,0,"insured bias"},-0.9,0.9,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insuredDispersion,0.01,"insured disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insurerBias,0,"insurer bias"},-0.9,0.9,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{insurerDispersion,0.01,"insurer disp."},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small}}]}],
ControlPlacement->Top,LabelStyle->{FontSize->12,FontFamily->"Swiss",myRed}],Style["Condensed Population Adjuster",{FontSize->16,FontFamily->"Swiss",mySeaFoam}],Top]

The insurance system

Manipulate[Dynamic@insuranceSystem[clusterStatisticsPalette,f0Basis,firstPointDirectives,fpiters,histogramLayout,histogramPalette,imax,imin,loadBasis,m1,m2,pointSizeBasis,q0Control,quantileAdjustmentFactor,safetyQuantile,showConditions,showCoverageRamps,showInsureds,showPremiumLines,show𝒮,tab,trajectoryColorPalette,trajectoryShow,v1,v2,xBasis,xhighControl,xlowControl,yBasis,yhighControl,ylowControl,Η,λ0,λcc0,λdirect,λMultiply,λρ,Π0,ρ],
(* ------- controls -----------*)

Control@{{Η,0,"behind the veil risk aversion (Η)"},0,5,0.1,Appearance->"Labeled",ImageSize->Small},
Control@{{fpiters,0,"fixed point list iterations"},0,20,1,Appearance->"Labeled",ImageSize->Small},
Pane[OpenerView[{"advanced system evolution controls",
Column[{
Control@{{safetyQuantile,0.5,"safety quantile"},0.1,0.9,0.1,Appearance->"Labeled",ImageSize->Small},
Control@{{Π0,0,"initial premium"},0,1,0.01,ImageSize->Small,Appearance->"Labeled"},
Row[{Control@{{q0Control,0.25,"quantile"},0,1,0.01,ImageSize->Small},Spacer[10],Dynamic[Round[Rescale[q0Control,{0,1},{0.01,1}],0.01]]}],
Control@{{quantileAdjustmentFactor,0.7,"quantile adjustment factor"},0.01,0.99,0.01,Appearance->"Labeled",ImageSize->Small}
}]
}],368],
Delimiter,

Pane[OpenerView[{"clustering",
Column[{Control@{{m1,1,"premium clusters"},Range[4]},
Control@{{m2,1,"care condition clusters"},Range[3]}
}]}],400],
Delimiter,
Pane[OpenerView[{"regulatory",
Column[{Control@{{ρ,0.1,"condition radius (ρ)"},0.01,0.3,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{loadBasis,"direct","load calculation method"},{"direct","parametric"}},
PaneSelector[{"direct"->Column[{Control@{{λdirect,0,"direct load"},-0.9,1,0.01,Appearance->"Labeled",ImageSize->Small}}],"parametric"->Row[{Column[{Control@{{λ0,0,"baseline load"},-0.9,1,0.01,Appearance->"Labeled",ImageSize->Small},
Control@{{λcc,0,"cluster count coefficient"},-0.2,0.2,0.005,Appearance->"Labeled",ImageSize->Small},Control@{{λρ,0,"ρ coefficient"},-0.9,1,0.01,Appearance->"Labeled",ImageSize->Small}}],"λ:",Spacer[6],Dynamic[λ0+λcc*(m1*m2-1)+λρ*ρ]}]},Dynamic[loadBasis]],
Control@{{imin,0,"minimum permitted insurance"},0,0.9,0.1,Appearance->"Labeled",ImageSize->Small},
Control@{{imax,1,"maximum permitted insurance"},0.1,1,0.1,Appearance->"Labeled",ImageSize->Small}}]}],368],
Delimiter,
Pane[OpenerView[{"visualization",
Column[{Control@{{show𝒮,True,"show behind-the-veil spectral measure"},{True,False}}, Control@{{tab,"traditional","visualization"},{"cluster statistics","traditional","histogram","grid","trajectory","raw"},ControlType->PopupMenu},
PaneSelector[{"cluster statistics"->Column[{Control@{{v1,1,"accident frequency cluster"},Dynamic@Range[m1],ControlType->SetterBar},Control@{{v2,1,"care condition cluster"},Dynamic@Range[m2],ControlType->SetterBar},Control@{{clusterStatisticsPalette,35,"palette"},1,62,1,ImageSize->Small,Appearance->"Labeled"}}],"histogram"->Column[{Control@{{histogramPalette,35,"palette index"},1,62,1,ImageSize->Small,Appearance->"Labeled"},Control@{{histogramLayout,"Stacked","layout"},{"Stacked","Overlapped"}}}],"grid"->Dynamic[(pickColumns=Range[13];Pane[CheckboxBar[Dynamic[pickColumns],Thread[Rule[Range[13],{"id","true risk","insured perceived risk","insurer perceived risk","loss","risk aversion","responsiveness","insurance","care","𝓈","acc. prob.","cov.","ℰ"}]],Enabled->(tab==="grid")],{390,140}])],
"raw"->Column[{Control@{{v1,1,"accident frequency cluster"},Dynamic@Range[m1],ControlType->SetterBar},Control@{{v2,1,"care condition cluster"},Dynamic@Range[m2],ControlType->SetterBar}}],
"trajectory"->Column[{Control@{{trajectoryShow,"strong","show trajectory how?"},{"strong","weak","none"}},Control@{{firstPointDirectives,"nothing special","initialization directive"},{"nothing special","large","large and color by end point"},ControlType->PopupMenu},

Control@{{trajectoryColorPalette,35,"trajectory color palette index"},1,62,1,Appearance->"Labeled",ImageSize->Small},Grid[{{Control@{{xlowControl,0,"x low"},0,1,ImageSize->Tiny},Control@{{xhighControl,1,"x high"},0,1,ImageSize->Tiny}},{Control@{{ylowControl,0,"y low"},0,1,ImageSize->Tiny},Control@{{yhighControl,1,"y high"},0,1,ImageSize->Tiny}}}]}],"traditional"->Column[{Grid[{{Control@{{xlowControl,0,"x low"},0,1,ImageSize->Tiny},Control@{{xhighControl,1,"x high"},0,1,ImageSize->Tiny}},{Control@{{ylowControl,0,"y low"},0,1,ImageSize->Tiny},Control@{{yhighControl,1,"y high"},0,1,ImageSize->Tiny}}}],Control@{{f0Basis,"true","f0 basis"},{"true","insured","insurer"},Enabled->(tab==="traditional")},
Control@{{xBasis,"acc. prob.","x coord. basis"},{"acc. prob.","acc. prob. × coverage"},Enabled->(tab==="traditional")},
Control@{{λMultiply,False,"multiply x-coordinate of points by λ"},{False,True},Enabled->(tab==="traditional")},
Control@{{yBasis,"risk aversion","y coord. basis"},{"risk aversion","care","insurance","responsiveness"},Enabled->tab==="traditional"},
Row[{Control@{{showInsureds,True,"show insureds as points"},{True,False}},Control@{{showPremiumLines,True,"show premiums"},{True,False}}}],
Row[{Control@{{showConditions,False,"show conditions"},{True,False},Enabled->yBasis==="care"},Spacer[18],Control@{{showCoverageRamps,False,"show coverage ramp",Enabled->yBasis==="care"},{True,False}}}],
Control@{{pointSizeBasis,"insurance","point size basis"},{"insurance","coverage","insurance×coverage"},Enabled->(tab==="traditional")}}]},Dynamic[tab]]}]
}],368],
LabelStyle->{FontFamily->"Swiss",FontSize->11},ControlPlacement->Left]

The Mathematica behind the Insurance System Manipulate

One final function that creates the contract trajectories and presents multiple visualization of the system' s evolution

Extensive use of OpenerGroup, PaneSelector and the Enabled option for context sensitive controls

Controls that determine initial premiums, initial condition quantiles, and parameters for adjusting quantiles when the system blows up

Controls that permit floors (mandatory insurance) and caps (uninsurable loss) on insurance

Choice of directly set or parametrically set load

Use of Pane in the controls section to tightly control layout

Room for improvement

Me

Use CUDA or OpenCL to truly parallelize code on individual decisions for purchasing insurance and taking care

More intelligent contract equilibration algorithm; maybe move in the direction that is likely to zero out profit and then, if multiple directions will do that to move in the direction that will increase insured wealth

Integrate population creation Manipulate with insurance system Manipulate

Another try at emulation using DataModeler or Neural Networks to permit more general admissible risk spectra, coverage ramps, and loss distributions

Wolfram Research

Mathematica should be able to compute with EmpiricalDistribution objects that have symbolic second parameters

Mean[EmpiricalDistribution[{a,b}->{0.1,0.9}]]

Mean[EmpiricalDistribution[{1,4}->{a,b}]]

Manipulate should handle first arguments with multiple random number generation in a cleaner way

NMaximize might handle constraints with a little more intelligence

NMaximize[{2 i(Sin[x]+3)Sin[(x^2)-3x+4],Or[i==0,i==1],0≤x≤6},{i,x}]//Timing

ParallelTable[NMaximize[2i (Sin[x]+3)Sin[(x^2)-3x+4],x],{i,0,1}]//Timing

NMaximize[{2 i(Sin[x]+3)Sin[(x^2)-3x+4],0≤i≤1,0≤x≤6},{i,x}]//Timing

Some details

Probability of an Insured Event

Perception of Risk (ex ante)

I do not assume that the insurer or insured has perfect information about their Insurer and insured perception of risk (fr and fd) are based on a draw from a Beta Distribution whose mean and standard deviation are based on f0 (the truth), bias (𝒷 ∈ (-1,1)) and an error parameter (ϵ ∈ [0,1)).

With[{cosmetics={{PlotRange->All,PlotStyle->Thick,Axes->False,Frame->True,FrameLabel->{"perceived risk","PDF"},ImagePadding->{{70,10},{50,10}},ImageSize->{700,250},AspectRatio->250/700,LabelStyle->{FontFamily->"Swiss",FontSize->18}}}},Manipulate[Plot[PDF[perceptionDistribution[f0,β,ϵ],t],{t,0,1},Epilog->{ColorData["Crayola"]["TropicalRainForest"],PointSize[0.02],Tooltip[Point[{f0,0}],Style["the truth",16]]},Evaluate[Sequence@@cosmetics]],{{f0,0.2,"f0 (true risk)"},0.01,0.99,0.01,Appearance->"Labeled"},{{β,0,"bias"},-0.99,0.99,0.01,Appearance->"Labeled"},{{ϵ,0.1,"error"},0.01,0.99,0.01,Appearance->"Labeled"},LabelStyle->{FontFamily->"Swiss",FontSize->18}]]

Satisfaction of Care Condition

The probability that the care condition will be satisfied following an accident is determined by considering the actual level of care x and a uniform distribution parameterized by the care condition Χ and a “tolerance radius” ρ.  In particular, the probability is CDF[UniformDistribution[{Χ-ρ,Χ+ρ}],x] for ρ>0 and ProbabilityDistribution[{“CDF”,UnitStep[x-Χ]},{x,0,∞}] for ρ==0.

With[{cosmetics={{PlotRange->All,PlotStyle->Thick,Axes->False,Frame->True,FrameLabel->{"actual care (x)","coverage probability"},ImagePadding->{{70,10},{50,10}},ImageSize->{700,250},AspectRatio->250/700,LabelStyle->{FontFamily->"Swiss",FontSize->18}}}},Manipulate[Plot[CDF[UniformDistribution[{Χ-ρ,Χ+ρ}],x],{x,0,3},Evaluate@(Sequence@@cosmetics)],{{Χ,0.3,"care condition (Χ)"},-2,2,0.01},{{ρ,0.1,"tolerance radius"},0,1,0.01}]]

Evaluation of Risk

Risk is evaluated based on a spectral measure, i.e. the expected quantile of the underlying lottery using a weighting function that has three characteristics: (1) its integral to the left of zero is 0; (2) its integral to the left of 1 is 1; and (3) it is non-increasing over the interval [0,1].

To permit rapid evaluation, the weighting function is as follows, where ϕ is a risk aversion parameter [0,1] and q is the quantile :

({{{, ({{(1/2) (2 ϕ+2)-2 q ϕ, 0<q<1}, {0, True}})}})

The End