our
$VERSION
=
'0.002003'
;
csshex_to_rgb255 colorname_to_csshex
)
;
our
@EXPORT_OK
=
qw(
to_px
br
to_rgb
group_to_NA
pdl_to_plotly
ribbon
)
;
our
%EXPORT_TAGS
= (
all
=> \
@EXPORT_OK
);
my
$dpi
= 96;
sub
to_px { mm_to_px(
$_
[0],
$dpi
) }
sub
_rgb {
my
(
$c
) =
@_
;
return
'transparent'
if
$c
eq
'BAD'
;
return
$c
=~ /^
}
sub
_rgba {
my
(
$c
,
$a
) =
@_
;
return
'transparent'
if
$c
eq
'BAD'
;
$c
=
$c
=~ /^
return
$c
if
$a
== 1;
if
(
$c
=~ /^
return
sprintf
(
"rgba(%s,%s,%s,%s)"
,
csshex_to_rgb255(
$c
),
0+
sprintf
(
"%.2f"
,
$a
)
);
}
return
$c
;
}
fun to_rgb (
$color
,
$alpha
=pdl(1)) {
state
$check
= Type::Params::compile((Piddle | Str), Piddle);
(
$color
,
$alpha
) =
$check
->(
$color
,
$alpha
);
if
( !
ref
(
$color
) ) {
return
_rgba(
$color
,
$alpha
->at(0));
}
else
{
if
(
$alpha
->
length
!=
$color
->
length
and
$alpha
->
length
!= 1) {
die
"alpha must be of length 1 or the same length as x"
;
}
$alpha
=
$alpha
->setbadtoval(1);
$alpha
->where(
$alpha
> 1) .= 1;
$alpha
->where(
$alpha
< 0) .= 0;
my
@color
=
$color
->flatten;
my
@rgba
;
if
(
$alpha
->uniq->
length
== 1 and
$alpha
->at(0) == 1) {
@rgba
=
map
{ _rgb(
$_
) }
@color
;
}
else
{
my
@alpha
=
$alpha
->flatten;
@rgba
= pairwise { _rgba(
$a
,
$b
) }
@color
,
@alpha
;
}
return
PDL::SV->new(\
@rgba
);
}
}
fun group_to_NA (
$df
, :
$group_vars
=[
'group'
],
:
$nested
=[], :
$ordered
=[], :
$retrace_first
=false) {
return
$df
if
(
$df
->nrow == 0 );
my
$df_names
=
$df
->names;
$group_vars
=
$group_vars
->intersect(
$df_names
);
$nested
=
$nested
->intersect(
$df_names
);
$ordered
=
$ordered
->intersect(
$df_names
);
unless
(
$group_vars
->
length
) {
my
@key_vars
= (
@$nested
,
@$ordered
);
return
(
@key_vars
?
$df
->
sort
( \
@key_vars
) :
$df
);
}
if
(
$df
->nrow == 1 ) {
return
(
$retrace_first
?
$df
->append(
$df
->select_rows(0) ) :
$df
);
}
$df
=
$df
->
sort
( [
@$nested
,
@$group_vars
,
@$ordered
] );
my
$changes_group
= (
$df
->select_columns(
$group_vars
)->id->diff != 0 );
my
$to_insert
=
$changes_group
;
if
(
$nested
->
length
> 0 ) {
my
$changes_nested
= (
$df
->select_columns(
$nested
)->id->diff == 0 );
$to_insert
= (
$to_insert
&
$changes_nested
);
}
my
$idx_to_insert
= which(
$to_insert
);
state
$split_range
=
sub
{
my
(
$upper
,
$after
) =
@_
;
return
(
pairmap { [
$a
..
$b
] }
(
0,
(
map
{ (
$_
,
$_
+ 1 ) }
grep
{
$_
<
$upper
}
$after
->flatten ),
$upper
)
);
};
my
@group_rows
=
$split_range
->(
$df
->nrow - 1,
$idx_to_insert
);
my
@splitted
=
map
{
$df
->select_rows(
$_
) }
@group_rows
;
if
(
$retrace_first
) {
my
$to_retrace
=
$changes_group
->glue( 0, pdl( [1] ) );
my
@retrace_at
=
map
{
my
$rindices
= pdl(
$_
);
which(
$to_retrace
->slice(
$rindices
) )->unpdl;
}
@group_rows
;
@splitted
=
map
{
my
$d
=
$splitted
[
$_
];
my
@retrace_rows
=
$split_range
->(
$d
->nrow - 1,
$retrace_at
[
$_
] );
my
@splitted_for_retrace
=
map
{
my
$x
=
$d
->select_rows(
$_
);
$x
->append(
$x
->select_rows( [0] ) )
}
@retrace_rows
;
reduce {
$a
->append(
$b
); } (
shift
@splitted_for_retrace
),
@splitted_for_retrace
;
} ( 0 ..
$#splitted
);
}
my
@key_vars
= (
@$nested
,
@$group_vars
);
my
@vars_to_na
=
grep
{ !elem(
$_
, \
@key_vars
) }
$df
->names->flatten;
return
(
reduce {
my
$na
=
$a
->select_rows( [
$a
->nrow - 1 ] )->copy;
for
my
$var
(
@vars_to_na
) {
$na
->at(
$var
)->setbadat(0);
}
$a
->append(
$na
)->append(
$b
);
}
(
shift
@splitted
),
@splitted
);
}
fun pdl_to_plotly (
$p
,
$allow_collapse
=false) {
return
[]
if
$p
->
length
== 0;
if
(
$p
->badflag ) {
return
$p
->unpdl;
}
if
(
$allow_collapse
) {
return
$p
->at(0)
if
$p
->
length
== 1;
if
(
$p
->
$_DOES
(
'PDL::SV'
) ) {
my
@lst
=
$p
->flatten;
my
$elem
=
shift
@lst
;
if
( all {
$_
eq
$elem
}
@lst
) {
return
$elem
;
}
}
else
{
my
$elem
=
$p
->at(0);
if
( (
$p
==
$elem
)->all ) {
return
$elem
;
}
}
}
return
$p
->unpdl;
}
fun ribbon (
$data
) {
my
$n
=
$data
->nrow;
my
$tmp
=
$data
->
sort
( [
'x'
] );
my
$tmp2
=
$data
->
sort
( [
'x'
], false );
my
$not_used
=
$data
->names->setdiff( [
qw(x ymin ymax y)
] );
my
@others
=
map
{
$_
=>
$tmp
->at(
$_
) }
@$not_used
;
my
$data1
= Data::Frame->new(
columns
=> [
x
=>
$tmp
->at(
'x'
),
y
=>
$tmp
->at(
'ymax'
),
@others
,
]
);
my
@others2
=
map
{
$_
=>
$tmp2
->at(
$_
) }
@$not_used
;
my
$data2
= Data::Frame->new(
columns
=> [
x
=>
$tmp2
->at(
'x'
),
y
=>
$tmp2
->at(
'ymin'
),
@others2
,
]
);
return
$data1
->rbind(
$data2
);
}
1;