n=10
Prime[n]

prim=Table[Prime[i],{i,1,n}];
ps=Table[0,{2^n}];
Do[

alt=IntegerDigits[p,2,n];
Clear[f];
Do[
f[prim[[i]]]=(-1)^alt[[i]]
,{i,1,n}
];
f[1]=-1;
ft={1};
Do[
If[!PrimeQ[i],
a=FactorInteger[i];
f[i]=Apply[Times,Map[f[#[[1]]]^#[[2]]&,a]];
];
ft={ft,ft[[-1]]+f[i]};
,{i,2,Prime[n]+1}
];
ft=Flatten[ft];
ps[[p+1]]=ft;

,{p,0,2^n-1}
]

max=Map[Max[Abs[#]]&,ps];
Min[max]
map=Flatten[Position[max,Min[max]]]
Length[map]
(2^n)/2

IntegerDigits[map[[1]],2,n]
IntegerDigits[map[[2]],2,n]

ListPlot[Log[2,max],AxesOrigin->{0,0},PlotLabel->"n = "<>ToString[n]]

n=50;
Prime[n]
m=2^10; (* Number of samples*)
prim=Table[Prime[i],{i,1,n}];
ps=Table[0,{m}];
Timing[
Do[

q=Random[Integer,{0,2^n-1}];

alt=IntegerDigits[q,2,n];
Clear[f];
Do[
f[prim[[i]]]=(-1)^alt[[i]]
,{i,1,n}
];
f[1]=1;
ft={1};
Do[
If[!PrimeQ[i],
a=FactorInteger[i];
f[i]=Apply[Times,Map[f[#[[1]]]^#[[2]]&,a]];
];
ft={ft,ft[[-1]]+f[i]};
,{i,2,Prime[n]+1}
];
ft=Flatten[ft];
ps[[p]]={q,Log[2,Max[Abs[ft]]]};

,{p,1,m}
];
]

ListPlot[ps,AxesOrigin->{0,0},PlotLabel->"n = "<>ToString[n]<>"   samples = "<>ToString[m]]

n=10

prim=Table[Prime[i],{i,1,n}];
ps=Table[0,{2^n}];
Do[

alt=IntegerDigits[p,2,n];
Clear[f];
Do[
f[prim[[i]]]=(-1)^alt[[i]]
,{i,1,n}
];
f[1]=1;
ft={1};
Do[
If[!PrimeQ[i],
a=FactorInteger[i];
f[i]=Apply[Times,Map[f[#[[1]]]^#[[2]]&,a]];
];
ft={ft,ft[[-1]]+f[i]};
,{i,2,Prime[n]+1}
];
ft=Flatten[ft];
ps[[p+1]]={Count[alt,1],Max[Abs[ft]]};

,{p,0,2^n-1}
]

ListPlot[ps,AxesOrigin->{0,0},PlotLabel->"n = "<>ToString[n],PlotRange->All]

n=10

prim=Table[Prime[i],{i,1,n}];
ps=Table[0,{2^n}];
Do[

alt=IntegerDigits[p,2,n];
Clear[f];
Do[
f[prim[[i]]]=(-1)^alt[[i]]
,{i,1,n}
];
f[1]=1;
ft={1};
Do[
If[!PrimeQ[i],
a=FactorInteger[i];
f[i]=Apply[Times,Map[f[#[[1]]]^#[[2]]&,a]];
];
ft={ft,ft[[-1]]+f[i]};
,{i,2,Prime[n]+1}
];
ft=Flatten[ft];
ps[[p+1]]={Length[Split[alt]],Max[Abs[ft]]};

,{p,0,2^n-1}
]

ListPlot[ps,AxesOrigin->{0,0},PlotLabel->"n = "<>ToString[n], PlotRange->All]