I'm doing some data analysis, and the output is a long list of numbers. Each line consists of 1 to n numbers, which may be duplicated:
1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 1 2 2 2 2 2 2 2 2 3 3 4
I'd like to put these into a (time-series) histogram. I'm not an expert in tcl (yet?), and I have some ideas how to do this but I have not been successful yet. The puts statements are just so I can see what's happening.
while { [gets $infile line] != -1 } {
set m [llength $line]
puts "line length $m"
foreach item $line {
puts $item
incr nc($item)
puts "nc: $nc($item)"
}
}
this nc array I've created is giving me a size-based array. However, I'd like a per-line based array (2D). Naively it would be nc($item)($nlines). I initially tried labeling the array variable with the length such as nc${item}($nlines), but I am not smart enough to get that to work.
I appreciate any help.
Best
Mike
Although Tcl arrays are one-dimensional, you can construct key strings to fake multi-dimensionality:
set lineno -1
set fh [open infile r]
while {[gets $fh line] != -1} {
incr lineno
foreach item [split [string trim $line]] {
incr nc($lineno,$item)
}
}
close $fh
# `parray` is a handy command for inspecting arrays
parray nc
outputs
nc(0,1) = 20
nc(0,2) = 8
nc(0,3) = 2
nc(0,4) = 1
nc(1,1) = 2
nc(1,2) = 4
nc(1,4) = 3
nc(2,1) = 1
nc(2,2) = 1
nc(2,3) = 1
nc(2,4) = 1
Or use dictionaries:
set lineno -1
set nc {}
set fh [open infile r]
while {[gets $fh line] != -1} {
set thisLine {}
foreach item [split [string trim $line]] {
dict incr thisLine $item
}
dict set nc [incr lineno] $thisLine
}
close $fh
dict for {line data} $nc {
puts [list $line $data]
}
outputs
0 {1 20 2 8 3 2 4 1}
1 {1 2 2 4 4 3}
2 {1 1 2 1 3 1 4 1}
I have read all the questions on stack overflow regarding rotating matrices
and none of them address anything other than transposing or rotating by 90 or 180 degrees in either direction of either single layers or the entire matrices.
I have already answered the question as far as accomplishing it but I am looking for fast and/or 'in place' methods, preferably, but any methods
other than the one I have given would be nice to see as well if only for
educational purposes. My example is in Perl 5 but as long as your intentions are clear, most any language should be acceptable.
The matrix used in my example is as follows
# 2D array #arr has 3 layers.
# #arr is
# 0 1 2 3 4 5
# a b c d e f
# 5 4 3 2 1 0
# 9 8 7 6 5 4
# f e d c b a
# 4 5 6 7 8 9
Goal->Rotate middle layer 2 places clockwise to get the following...
Notice how the top left corner of the middle layer, 'b c', has moved 2 places to the right and the '8 4' from the middle left side is now where the 'b c' was.
# Rotated #arr is
# 0 1 2 3 4 5
# a 8 4 b c f
# 5 e 3 2 d 0
# 9 d 7 6 e 4
# f c b 5 1 a
# 4 5 6 7 8 9
Currently I have been doing something along the lines of this, which is admittedly, terribly slow. Especially on many large arrays.
#!/usr/bin/env perl
use strict; use warnings;
# Coordinates are $arr[$row][$col]
my #arr;
$arr[0][0]='0'; $arr[0][1]='1'; $arr[0][2]='2'; $arr[0][3]='3'; $arr[0][4]='4'; $arr[0][5]='5';
$arr[1][0]='a'; $arr[1][1]='b'; $arr[1][2]='c'; $arr[1][3]='d'; $arr[1][4]='e'; $arr[1][5]='f';
$arr[2][0]='5'; $arr[2][1]='4'; $arr[2][2]='3'; $arr[2][3]='2'; $arr[2][4]='1'; $arr[2][5]='0';
$arr[3][0]='9'; $arr[3][1]='8'; $arr[3][2]='7'; $arr[3][3]='6'; $arr[3][4]='5'; $arr[3][5]='4';
$arr[4][0]='f'; $arr[4][1]='e'; $arr[4][2]='d'; $arr[4][3]='c'; $arr[4][4]='b'; $arr[4][5]='a';
$arr[5][0]='4'; $arr[5][1]='5'; $arr[5][2]='6'; $arr[5][3]='7'; $arr[5][4]='8'; $arr[5][5]='9';
# Print matrix
print_matrix(#arr);
# Extract layer 2
my $target_layer=2;
my $layer_two=extract_layer($target_layer,#arr);
# From the top left corner of the layer, it is as follows
# bcde15bcde84
print "\n$layer_two\n";
# Rotate layer 2 clockwise 2 places
$layer_two=rotate_layer_cl($layer_two,2);
# 84bcde15bcde
print "$layer_two\n\n";
# Replace layer 2 in the same way
#arr=replace_layer($target_layer,$layer_two,#arr);
# Print again
print_matrix(#arr);
### Sub functions ###
# Extract layer by walking around it's coordinates like so
# [1,1]-[1,4] Top(left->right)
# [2,4]-[4,4] Right(top->bottom)
# [4,3]-[4,1] Bottom(right->left)
# [3,1]-[2,1] Left(bottom->top)
sub extract_layer {
my ($layer_cnt,#matrix)=#_;
my $width=scalar(#matrix);
my $layer_width=$width-$layer_cnt;
# layer_cnt=2
# width=6
# layer_width=4
my $layer;
for my $col ( $layer_cnt-1..$layer_width ) {
$layer.=$matrix[$layer_cnt-1][$col];
}
for my $row ( $layer_cnt..$layer_width ) {
$layer.=$matrix[$row][$layer_width];
}
my $cnt=$layer_width-1;
while ( $cnt >= $layer_cnt-1 ) {
$layer.=$matrix[$layer_width][$cnt];
$cnt--;
}
$cnt=$layer_width-1;
while ( $cnt >= $layer_cnt ) {
$layer.=$matrix[$cnt][$layer_cnt-1];
$cnt--;
}
return $layer;
}
# Shift input to the right by $n places, wrapping around.
sub rotate_layer_cl {
my $n=$_[1];
my $buf=substr($_[0],length($_[0])-$n,$n);
return $buf.substr($_[0],0,length($_[0])-$n);
}
# Replace each char from the rotated layer.
sub replace_layer {
my ($layer_cnt,$layer,#matrix)=#_;
my $width=scalar(#matrix);
my $layer_width=$width-$layer_cnt;
# layer_cnt=2
# width=6
# layer_width=4
my $slot=0;
for my $col ( $layer_cnt-1..$layer_width ) {
$matrix[$layer_cnt-1][$col]=substr($layer,$slot,1);
$slot++;
}
for my $row ( $layer_cnt..$layer_width ) {
$matrix[$row][$layer_width]=substr($layer,$slot,1);
$slot++;
}
my $cnt=$layer_width-1;
while ( $cnt >= $layer_cnt-1 ) {
$matrix[$layer_width][$cnt]=substr($layer,$slot,1);
$slot++;
$cnt--;
}
$cnt=$layer_width-1;
while ( $cnt >= $layer_cnt ) {
$matrix[$cnt][$layer_cnt-1]=substr($layer,$slot,1);
$slot++;
$cnt--;
}
return #matrix;
}
# Prints given matrix
sub print_matrix {
foreach my $row (#_) {
my $cnt=0;
foreach my $char (#$row) {
print $char; $cnt++;
if ( $cnt == scalar(#_) ) {
print "\n";
} else {
print " ";
}
}
}
}
The above code outputs as follows,
0 1 2 3 4 5
a b c d e f
5 4 3 2 1 0
9 8 7 6 5 4
f e d c b a
4 5 6 7 8 9
bcde15bcde84
84bcde15bcde
0 1 2 3 4 5
a 8 4 b c f
5 e 3 2 d 0
9 d 7 6 e 4
f c b 5 1 a
4 5 6 7 8 9
which shows the array before rotating the middle layer, the middle layer as a string, the middle layer shifted as a string, and the final resulting array after the middle layer has been rotated 2 places to the right.
-----EDIT-----
So far, the fastest method I have found is to not actually use the full 2D array but to put the block in a regular array like...
my #hex_ary=('1234', '5678', '90ab', 'cdef');
Then create the layer string and shift it the same way my original example shows.
However, because they are strings, I only need to "walk" up and down the sides. The top and bottom are simply referenced as...
my $top=substr($hex_ary[0],0,3);
and
my $bot=reverse(substr($hex_ary[3],0,3));
for the outer layer in this small 4x4 array, while the sides are itered through with
my $right_side_char=substr($hex_ary[$top_row-$i],-1);
my $left_side_char=substr($hex_ary[$bot_row+$i],0,1);
Doing so increases performance approx. 100% from the 2D method because the number of slices taken from the array is then half+2.
Maybe someone with a better grasp of C could create something more efficient. I feel like Perl is just only capable of so much sometimes.
The idea of my method is to use a queue (well, I'm using a Perl array here because I couldn't find a suitable module, but it's far from ideal) containing n elements (where n is the number of places you want to rotate your layer by), and to iterate through each elements of the layer, and each time, push its value to the queue, and replace it with the first element of the queue.
This is what the sub rotate_matrix does.
- $i and $j represent the index of the current element of the layer. Their values goes between $target_layer and $max_i/$max_j; the sub next_ij takes care of computing the index of the next element of the layer.
- The interesting stuffs happen inside the while(1) loop (which is actually a do...while; but do while loops are a bit special in Perl): the value of the current element is pushed to the queue, and, if their are more than $n elements in the queue (meaning that we have already pushed $n elements, representing the fact the we want to rotate by $n), we replace its value by the first element of the queue. The continue block takes care of incrementing $i and $j, and stops the loop once we come back to the first element of the layer.
- Once this is loop is done, the first n elements of the layer haven't been updated (because of this next unless #queue > $n), so we need to take care of that: this is the while (#queue) loop).
Complexity-wise, there is no need to copy the array. The memory usage is O(n) (the size of the queue). Time-wise, you loop once over each element of the layer, and each time, you push and shift from you queue (using a better datastructure, like a linked list, this would be O(1), but with a Perl array, it's probably in the lines of O(n); but probably amortized to O(1)), and compute the next index (O(1)). So you end up with a time complexity, you end up with O(size of the layer to rotate).
A few caveats: if $n is greater than the number of elements in the layer, this won't work (but it can be fixed with a simple modulo). If you ask for a layer that isn't present in the matrix (like 4-th layer of a 2x2 matrix), weird stuffs will happen (but once again, it's easy to fix).
#!/usr/bin/perl
use strict;
use warnings;
use v5.14;
my #arr = ( [qw(0 1 2 3 4 5)],
[qw(a b c d e f)],
[qw(5 4 3 2 1 0)],
[qw(9 8 7 6 5 4)],
[qw(f e d c b a)],
[qw(4 5 6 7 8 9)] );
print_matrix(#arr);
rotate_matrix(\#arr, 2, 2);
say "";
print_matrix(#arr);
sub rotate_matrix {
my ($matrix, $target_layer, $n) = #_;
--$target_layer; # I prefer a 0-indexed value
# TODO: check that $target_layer < #$matrix/2
# TODO: do something like $n = $n % (num of elements in layer)
my #queue;
my ($i, $j) = ($target_layer, $target_layer);
my ($max_i, $max_j) = (#{$matrix->[0]}-$target_layer-1, #$matrix-$target_layer-1);
while (1) { # Actually a do...while loop (see 'continue' block)
push #queue, $matrix->[$i][$j];
next unless #queue > $n; # Waiting to reach n-th element
$matrix->[$i][$j] = shift #queue;
} continue {
($i, $j) = next_ij($target_layer,$max_i,$max_j,$i,$j);
# Stopping if we are back at the begining
last if $i == $target_layer && $j == $target_layer;
}
# Emptying queue
while (#queue) {
$matrix->[$i][$j] = shift #queue;
($i, $j) = next_ij($target_layer,$max_i,$max_j,$i,$j);
}
}
# Computes the index of the next element of the layer
sub next_ij {
my ($target_layer, $max_i, $max_j, $i, $j) = #_;
if ($j == $max_j) { # Last column
if ($i == $max_i) { # Last row (bottom right -> going left)
return ($i, $j-1);
} else { # Not last row (somewhere on the right col -> going down)
return ($i+1, $j);
}
} elsif ($j == $target_layer) { # First column
if ($i == $target_layer) { # First row (top left -> going right)
return ($i, $j+1);
} else { # Not top row (somewhere on the left col -> going up)
return ($i-1, $j);
}
} else { # Neither first nor last column
if ($i == $target_layer) { # First row (somewhere on the top row -> going right)
return ($i, $j+1);
} else { # Last row (somewhere on the last row -> going left)
return ($i, $j-1);
}
}
}
# Prints given matrix
sub print_matrix {
foreach my $row (#_) {
my $cnt=0;
foreach my $char (#$row) {
print $char; $cnt++;
if ( $cnt == scalar(#_) ) {
print "\n";
} else {
print " ";
}
}
}
}
The approach in a nutshell:
copy array
calculate list of members (row, column) for the ring
loop over list index
read from member[index] in original array
write to member[(index + shift) % ring length] in copy array
Right shift by N places: shift == N
Left shift by N places: shift == -N
#!/usr/bin/perl
use strict;
use warnings;
sub dump_array($$) {
my($label, $array) = #_;
print "${label}:\n";
foreach my $row (#{ $array }) {
print join(" ", #{ $row }), "\n";
}
print "\n";
}
sub copy_array($) {
my($array) = #_;
my #copy;
foreach my $row (#{ $array }) {
push(#copy, [ #{ $row } ]);
}
return(\#copy);
}
sub ring_index_to_row_col($$$$$) {
my($N, $ring, $total, $length, $index) = #_;
my($row, $col);
if ($index < $length) {
# top row, left to right
$row = 0;
$col = $index;
} elsif ($index < 2 * $length - 2) {
# top to bottom, right row
$row = $index - $length + 1;
$col = $N - 1 - 2 * $ring;
} elsif ($index < 3 * $length - 2) {
# bottom row, right to left
$row = $N - 1 - 2 * $ring;
#$col = $length - 1 - ($index - 2 * $length + 2);
$col = -$index + 3 * $length - 3;
} else {
# bottom to top, left row
#$row = $total - 1 - $index + 1;
$row = $total - $index;
$col = 0;
}
#print "${index}\t of ${total}\t-> ${row}, ${col}\n";
# shift $length x length array to offset ($ring, $ring)
return([$row + $ring, $col + $ring]);
}
sub ring_members($$) {
my($N, $ring) = #_;
my #list;
# #TODO: odd N?
#
# Examples for N == 6
# 0 -> 2*6 + 2*4 = 20
# 1 -> 2*4 + 2*2 = 12
# 2 -> 2*2 + 2*0 = 4
#
# Examples for N == 5
# 0 -> 2*5 + 2*3
# 1 -> 2*3 + 2*1
# 2 -> 1
#
# Examples for N == 4
# 0 -> 2*4 + 2*2 = 12
# 1 -> 2*2 + 2*0 = 4
my $length = $N - 2 * $ring;
my $members = 4 * $N - 8 * $ring - 4;
foreach my $index (0..$members-1) {
push(#list, ring_index_to_row_col($N, $ring, $members, $length, $index));
}
return(\#list);
}
sub rotate_array_ring(\#$$) {
my($source, $ring, $shift) = #_;
# Sanity check. #TODO is the check correct for odd N?
my $N = #{ $source };
die "ERROR: invalid ring '${ring}' for 2D array of size $N!\n"
unless $ring < ($N / 2);
my $copy = copy_array($source);
my $list = ring_members($N, $ring);
my $length = #{ $list };
foreach my $index (0..$length-1) {
my($row, $col) = #{ $list->[ $index ] };
my($s_row, $s_col) = #{ $list->[($index + $shift) % $length ] };
$copy->[$s_row]->[$s_col] = $source->[$row]->[$col];
}
return($copy);
}
my #source;
while (<DATA>) {
chomp;
push(#source, [ split(/\s+/, $_) ]);
}
dump_array('SOURCE', \#source);
dump_array('SHIFT 1 RING 0', rotate_array_ring(#source, 0, 1));
dump_array('SHIFT 1 RING 1', rotate_array_ring(#source, 1, 1));
dump_array('SHIFT 1 RING 2', rotate_array_ring(#source, 2, 1));
dump_array('SHIFT 2 RING 0', rotate_array_ring(#source, 0, 2));
dump_array('SHIFT 2 RING 1', rotate_array_ring(#source, 1, 2));
dump_array('SHIFT 2 RING 2', rotate_array_ring(#source, 2, 2));
exit 0;
__DATA__
0 1 2 3 4 5
a b c d e f
5 4 3 2 1 0
9 8 7 6 5 4
f e d c b a
4 5 6 7 8 9
Example output:
$ perl dummy.pl
SOURCE:
0 1 2 3 4 5
a b c d e f
5 4 3 2 1 0
9 8 7 6 5 4
f e d c b a
4 5 6 7 8 9
SHIFT 1 RING 0:
a 0 1 2 3 4
5 b c d e 5
9 4 3 2 1 f
f 8 7 6 5 0
4 e d c b 4
5 6 7 8 9 a
SHIFT 1 RING 1:
0 1 2 3 4 5
a 4 b c d f
5 8 3 2 e 0
9 e 7 6 1 4
f d c b 5 a
4 5 6 7 8 9
SHIFT 1 RING 2:
0 1 2 3 4 5
a b c d e f
5 4 7 3 1 0
9 8 6 2 5 4
f e d c b a
4 5 6 7 8 9
SHIFT 2 RING 0:
5 a 0 1 2 3
9 b c d e 4
f 4 3 2 1 5
4 8 7 6 5 f
5 e d c b 0
6 7 8 9 a 4
SHIFT 2 RING 1:
0 1 2 3 4 5
a 8 4 b c f
5 e 3 2 d 0
9 d 7 6 e 4
f c b 5 1 a
4 5 6 7 8 9
SHIFT 2 RING 2:
0 1 2 3 4 5
a b c d e f
5 4 6 7 1 0
9 8 2 3 5 4
f e d c b a
4 5 6 7 8 9
OPTIMIZATION: don't copy the whole array, but
use $list to copy out the ring members to a list and then
loop over that list to place them into the shifted position back into the array.
I.e. two loops instead of one:
my $list = ring_members($N, $ring);
my $length = #{ $list };
# in-place approach
my #members;
foreach my $index (0..$length-1) {
my($row, $col) = #{ $list->[ $index ] };
push(#members, $source->[$row]->[$col]);
}
foreach my $index (0..$length-1) {
my($row, $col) = #{ $list->[ ($index + $shift) % $length ] };
$source->[$row]->[$col] = $members[$index];
}
return($source);
OPTIMIZATION 2: if you have a sequence of operations that you need to apply to a set of same-sized 2D arrays, then you could pre-generate them and process them over-and-over using a function:
my $N = 6; # all arrays are of same size
my #rings = (
ring_members($N, 0),
ring_members($N, 1),
ring_members($N, 2),
);
my #operations = (
{ ring => $rings[0], shift => 1 },
{ ring => $rings[1], shift => -1 },
{ ring => $rings[2], shift => 2 },
# ...
)
# apply one operation in-place on array
sub apply_operation($$) {
my($array, $operation) = #_;
my $list = $operation->{ring};
my $shift = $operation->{shift};
my $length = #{ $list };
my #members;
foreach my $index (0..$length-1) {
my($row, $col) = #{ $list->[ $index ] };
push(#members, $array->[$row]->[$col]);
}
foreach my $index (0..$length-1) {
my($row, $col) = #{ $list->[ ($index + $shift) % $length ] };
$array->[$row]->[$col] = $members[$index];
}
}
# apply operation sequence in-place on array
sub apply_operations($$) {
my($array, $operations) = #_;
foreach my $operation (#{ $operations }) {
apply_operation($array, $operation);
}
}
apply_operations(\#array1, \#operations);
apply_operations(\#array2, \#operations);
apply_operations(\#array3, \#operations);
...
OPTIMIZATION 3: don't make a copy of the complete group in the in-place approach, but only of those members which would be overwritten by the roation. I.e. use 3 loops:
copy the first or last $shift members (depending on the rotation direction) to #cache array.
do a straight copy for the other $length - abs($shift) members.
copy #cache members to their rotated places.
OPTIMIZATION 4: don't use a 2D array (AoA) but a 1D array with $N * $N entries. I.e.
instead of ring_index_to_row_col() returning [$row, $col] you would have ring_index_to_array_index() returning $row * $N + $col.
array accesses ->[$row]->[$col] would be replaced with ->[$array_index].
I have a file in Tcl, and I want to read each value alone as the array... I recognize my file like this
PUx(1) 1 2 3 4 5
PUx(2) 1 2 3 4 5
PUx(3) 1 2 3 4 5
PUx(4) 1 2 3 4 5
PUx(5) 1 2 3 4 5
So, I want to get, for example, the value of PUx(1) one by one and add it to the variable.
enter image description here
As Donal pointed out, it all depends on the actual format. But if the example data is representative, this might work for you:
set content {PUx(1) 1 2 3 4 5
PUx(2) 1 2 3 4 5
PUx(3) 1 2 3 4 5
PUx(4) 1 2 3 4 5
PUx(5) 1 2 3 4 5}
foreach line [split $content \n] {
set values [lassign $line varName]
set $varName $values
}
parray PUx
lassign assumes the line-wise data to represent a valid Tcl list. This might or might not be the case for you.
Update
You might want to re-organize your dataset, this would allow you to use a Tcl array idiom to access "rows" and "columns" of data in a straightforward manner, more or less:
set content {PUx(1,1) 1
PUx(1,2) 2
PUx(1,3) 3
PUx(1,4) 4
PUx(1,5) 5
PUx(2,1) 1
PUx(2,2) 2
PUx(2,3) 3
PUx(2,4) 4
PUx(2,5) 5}
foreach line [split $content \n] {
set values [lassign $line varName]
set $varName $values
}
parray PUx
# first column: *,1
foreach {k v} [array get PUx *,1] {
puts $v
}
# first row: 1,*
foreach {k v} [array get PUx 1,*] {
puts $v
}
Provided that your main concern is how to compute the sum over a list of elements, these are three options available to:
proc lsum1 {x} {
set r 0
foreach i $x {
incr r $i
}
return $r
}
proc lsum2 {x} {
expr [join $x " + "]
}
proc lsum3 {x} {
::tcl::mathop::+ {*}$x
}
set x {1 2 3 4 5}
lsum1 $x
lsum2 $x
lsum3 $x
lsum1 and lsum3 are preferable. lsum2 is the literate translation of what you describe as your "problem", at least in my reading. You may also want to check the Tcl wiki. It gives you some background on the details of lsum3.
This can be easily integrated with reading your data, as shown in my first answer:
lsum1 $PUx(1)
lsum3 $PUx(1)
I want to modify an array (I'm using splice in this example, but it could be any operation that modifies the array) and return the modified array - unlike slice, which returns the items pulled out of the array. I can do it easily by storing a block in an array, as follows:
my $l = -> $a { splice($a,1,3,[1,2,3]); $a };
say (^6).map( { $_ < 4 ?? 0 !! $_ } ).Array;
# [0 0 0 0 4 5]
say (^6).map( { $_ < 4 ?? 0 !! $_ } ).Array.$l;
# [0 1 2 3 4 5]
How do I inline the block represented by $l into a single expression? The obvious substitution doesn't work:
say (^6).map( { $_ < 4 ?? 0 !! $_ } ).Array.(-> $a { splice($a,1,3,[1,2,3]); $a })
Invocant requires a type object of type Array, but an object instance was passed. Did you forget a 'multi'?
Any suggestions?
Add one & at the right spot.
say (^6).map( { $_ < 4 ?? 0 !! $_ } ).Array.&(-> $a { splice($a,1,3,[1,2,3]); $a })
# OUTPUT«[0 1 2 3 4 5]»