1=head1 NAME
2
3Tk::TableMatrix::SpreadsheetHideRows - Table Display with selectable hide/un-hide of rows
4
5=head1 SYNOPSIS
6
7  use Tk;
8  use Tk::TableMatrix::SpreadsheetHideRows
9
10  my $t = $top->Scrolled('SpreadsheetHideRows',
11    -selectorCol => 3,
12    -expandData => $hashRef,
13    -rows => 21, -cols => 11,
14    -width => 6, -height => 6,
15    -titlerows => 1, -titlecols => 1,
16    -variable => $arrayVar,
17    -selectmode => 'extended',
18    -resizeborders => 'both',
19    -bg => 'white',
20  );
21
22=head1 DESCRIPTION
23
24L<Tk::TableMatrix::SpreadsheetHideRows> is a L<Tk::TableMatrix::Spreadsheet>-derived widget that implements
25a Spreadsheet-like display of tabular information, where some of the rows in the table
26can be expanded/hidden by clicking a '+/-' selector in the row. This can be used to display
27top-level information in a table, while allowing the user to expand certain table rows to
28view detail-level information.
29
30See demos/SpreadsheetHideRows in the source distribution for a simple example of this widget
31
32=head1 Widget-specific Options
33
34In addition the standard L<Tk::TableMatrix> widget options. The following options are implemented:
35
36=over 1
37
38=item  -selectorCol
39
40Column number where the +/- selector will appear. Clicking on the +/- selector
41will expand/hide the detail information in the table for a particular row.
42
43=item  -selectorColWidth
44
45Width of the column used to display the +/- selector. Defaults to 2
46
47=item -expandData
48
49Hash ref defining the detail-level data displayed when a row is expanded (by clicking
50the +/- selector). This hash ref should have the following structure:
51
52  $expandData = {
53  	row1 => {  tag  => 'detailDataTag',
54	           data => $detailData,
55		   spans=> $spanData,
56		   expandData => $subLevelData
57		},
58	row2 => {
59	   .
60	   .
61  }
62
63  Where:
64    row1, row2, ... 	    Row numbers that will be expandable.
65    tag => 'detailDataTag'  Tag name that will be applied to the detail data.
66    			    (optional)
67    $detailData              2D Array of detail-data to be displayed when
68    			     the row is expanded.
69			     e.g. [ [ r1c1, r1c2, r1c3 ],
70			            [ r2c1, r2c2, r2,c3] ]
71    $spans                   1D array of span information (optional) to be
72    			     used for display of the detail information.
73			     e.g.  [ col2 =>  "rows,cols", col4 =>  "rows,cols", ... ]
74
75    $subLevelData            Optional Recursive expandData used to hold detail-data of detail-data.
76
77
78
79=back
80
81=head1 MEMBER DATA
82
83The following items are stored as member data
84
85=over 1
86
87=item defaultCursor
88
89Name of the mouse cursor pointer that is used for normal (i.e. non-title, non-indicator) cells in the widget.
90This is set to the value of the $widget->cget(-cursor) option when the widget is created.
91
92=item indRowCols
93
94Hash ref of Row/Cols indexes where there are indicators stores. This is a quick
95lookup hash built from I<_expandData>.
96
97=item _expandData
98
99Internal version of the I<expandData> hash. Any sub-detail data (i.e. expand data
100that is at lower levels of I<expandData>) that is visible is placed at the top level of this hash, for
101keeping track of the visible I<expandData>.
102
103=back
104
105=head1 Widget Methods
106
107In addition the standard L<Tk::TableMatrix> widget method. The following methods are implemented:
108
109
110=cut
111
112package Tk::TableMatrix::SpreadsheetHideRows;
113
114use Carp;
115
116
117use Tk;
118use Tk::TableMatrix::Spreadsheet;
119use Tk::Derived;
120
121use base qw/ Tk::Derived Tk::TableMatrix::Spreadsheet/;
122
123$VERSION = '1.26';
124
125
126Tk::Widget->Construct("SpreadsheetHideRows");
127
128
129sub ClassInit{
130	my ($class,$mw) = @_;
131
132	$class->SUPER::ClassInit($mw);
133
134
135
136};
137
138
139sub Populate {
140    my ($self, $args) = @_;
141
142    $self->ConfigSpecs(
143       -selectorCol     => 	[qw/METHOD selectorCol     SelectorCol/,    undef],
144       -selectorColWidth=> 	[qw/PASSIVE selectorColWidth     SelectorColWidth/,    2],
145       -expandData      => 	[qw/METHOD expandData     ExpandData/,    {}],
146   );
147
148
149    $self->SUPER::Populate($args);
150
151    $self->tagConfigure('plus', -image =>  $self->Getimage("plus"), -showtext => 0, -anchor => 'center');
152    $self->tagConfigure('minus', -image =>  $self->Getimage("minus"), -showtext => 0,  -anchor => 'center');
153
154    $self->{normalCursor} = $self->cget('-cursor'); # get the default cursor
155
156
157}
158
159=head2 showDetail
160
161Shows (i.e. expands the table) the detail data for a given row. This method is called
162when a user clicks on an indicator that is not already expanded.
163
164B<Usage:>
165
166 $widget->showDetail($row);
167
168 # Shows the detail data for row number $row
169
170=cut
171
172sub showDetail{
173
174	my $self = shift;
175
176	my $row = shift;
177
178	my $selectorCol = $self->cget(-selectorCol);
179
180	my $index = "$row,$selectorCol"; # make index for the cell to be expanded
181
182	my $indRowCols = $self->{indRowCols};
183
184	$self->tagCell('minus', $index);
185	$indRowCols->{$index} = '-';
186
187	# Get the detail data and insert:
188	my $expandData = $self->{'_expandData'};
189	my $detailData = $expandData->{$row};
190	my $detailArray = $detailData->{data};
191
192	my $noRows = scalar( @$detailArray);
193
194	# InsertRows:
195	#    change state to normal if not already so we can insert
196	my $currentState = $self->cget(-state);
197	$self->configure(-state => 'normal') unless( $currentState eq 'normal');
198	$self->insertRows($row,$noRows);
199
200	# Adjust Spans:
201	$self->adjustSpans($row+1,$noRows);
202
203	#insert data
204	my $colorigin =  $self->cget(-colorigin);
205	my $rowNum = $row+1;
206	foreach my $rowData( @$detailArray ){
207		#my @rowArray = @$rowData;
208		#grep s/([\{\}])/\\$1/g, @rowArray; # backslash any existing '{' chars, so they don't get interpreted as field chars
209		my $insertData = "{".join("}{", @$rowData)."}"; # make insert data look like tcl array, so it
210								# gets put in different cells
211		$self->set('row', "$rowNum,$colorigin", $insertData);
212		$rowNum++;
213	}
214
215	# Apply Tags, if any:
216	my $tag;
217	if( defined( $detailData->{tag})){
218		$tag = $detailData->{tag};
219		my $startRow = $row+1;
220		my $noRows = @$detailArray;
221		my $stopRow = scalar(@$detailArray) + $startRow - 1;
222		my @tagRows = ($startRow..$stopRow);
223		$self->tagRow($tag,@tagRows);
224	}
225
226	# Apply Spans, if any:
227	my $spans;
228	if( defined( $detailData->{spans})){
229		$spans = $detailData->{spans};
230
231		my $spanSize = scalar(@$spans);
232		#Error Checking, spans array should be a multiple of 2
233		if( ($spanSize % 2) < 1){
234
235			my $startRow = $row+1;
236			my $noRows = @$detailArray;
237			my $stopRow = scalar(@$detailArray) + $startRow - 1;
238			foreach my $spanRow($startRow..$stopRow){
239				# build an array to feed to spans, change column number for row.col index
240				#   (every 2rd item in the array).
241				my @spanArray = map $_ % 2 ? $spans->[$_] : "$spanRow,".$spans->[$_], (0..($spanSize-1));
242				$self->spans(@spanArray);
243			}
244
245		}else{
246			warn("Spans array for row $row, is not a multiple of 2\n");
247		}
248
249	}
250
251
252
253
254	# Now Update the internal arrays for the inserted rows ###
255	my %expandDataNew;
256	foreach my $rowIndex(keys %$expandData){
257		if($rowIndex > $row){ # adjust rows greater than the current row
258			$expandDataNew{$rowIndex+$noRows} = $expandData->{$rowIndex};
259		}
260		else{
261			$expandDataNew{$rowIndex} = $expandData->{$rowIndex};
262		}
263	}
264	# Copy new to existing:
265	%$expandData = %expandDataNew;
266
267
268	my %indRowColsNew;
269	foreach my $rcindex(keys %$indRowCols){
270
271		my ($rowIndex,$colIndex) = split(',',$rcindex);
272		if($rowIndex > $row){ # adjust rows greater than the current row
273			my $newRow = $rowIndex+$noRows;
274			$indRowColsNew{"$newRow,$colIndex"} = $indRowCols->{$rcindex};
275		}
276		else{
277			$indRowColsNew{$rcindex} = $indRowCols->{$rcindex};
278		}
279	}
280	# Copy new to existing:
281	%$indRowCols = %indRowColsNew;
282
283	# Take care of any lower-level detail data:
284	my $subDetail;
285	if( defined( $detailData->{expandData})){
286		$subDetail = $detailData->{expandData};
287
288		foreach my $subRow( keys %$subDetail){
289
290			my $realRow = $row+$subRow;
291			my $index = "$realRow,$selectorCol";
292			$self->tagCell('plus', $index);
293			$indRowCols->{$index} = '+'; # update internal array
294
295			# put subdetail data to top level, adjusting the relative row
296			# numbers to real row numbers:
297			#my %adjustedSubDetail;
298			#foreach my $subKey(keys %$subDetail){
299			#	$adjustedSubDetail{$subKey+$row} = $subDetail->{$subKey};
300			#}
301			$expandData->{$realRow} = $subDetail->{$subRow};
302		}
303
304	}
305
306	# Put the state back
307	$self->configure(-state => $currentState) unless( $currentState eq 'normal');
308
309
310}
311
312=head2 hideDetail
313
314Hides the detail data for a given row. This method is called
315when a user clicks on an indicator that is already expanded.
316
317B<Usage:>
318
319 $widget->hideDetail($row);
320
321 # Hides the detail data for row number $row
322
323=cut
324
325sub hideDetail{
326
327	my $self = shift;
328
329	my $row = shift;
330	my $expandData = shift;
331	my $detailData = $expandData->{$row};
332
333	my $selectorCol = $self->cget(-selectorCol);
334
335	my $index = "$row,$selectorCol"; # make index for the cell to be hidden
336
337	my $indRowCols = $self->{indRowCols};
338
339	# hide any sublevel data first:
340	my $lowerLevelHideRows = 0;
341	if( defined( $detailData->{expandData})){ # sublevel data exists
342		my $subLevelData = $detailData->{expandData};
343		# convert sublevel data to absolute rows
344		my $convertedSubData = {};
345		foreach my $rowNum(keys %$subLevelData){
346			$convertedSubData->{$rowNum+$row} = $subLevelData->{$rowNum};
347		}
348		#Hide lower level data, if showing
349		my $subLevelIndex;
350		foreach my $rowNum (sort {$a<=>$b} keys %$convertedSubData){
351			$subLevelIndex = "$rowNum,$selectorCol";
352			if( $indRowCols->{$subLevelIndex} eq '-'){
353				# For lower-level hide-detail calls, we don't use any updates to the
354				#   expandData Arg, so we create an anonymous hash ref in this call
355				$lowerLevelHideRows += $self->hideDetail($rowNum,{ %$convertedSubData} );
356			}
357		}
358	}
359
360
361	$self->tagCell('plus', $index);
362	$indRowCols->{$index} = '+';
363
364
365	# Get the detail data and hide:
366	my $detailArray = $detailData->{data};
367
368	my $noRows = scalar( @$detailArray);
369
370	# unapply any spans (This is not auto-handled by the row delete command, so we
371	#  have to do it here manually)
372	my $spans;
373	if( defined( $detailData->{spans})){
374		$spans = $detailData->{spans};
375
376		my $spanSize = scalar(@$spans);
377		#Error Checking, spans array should be a multiple of 2
378		if( ($spanSize % 2) < 1){
379
380			my $startRow = $row+1;
381			my $noRows = @$detailArray;
382			my $stopRow = scalar(@$detailArray) + $startRow - 1;
383			foreach my $spanRow($startRow..$stopRow){
384				# build an array to feed to spans, change column number for row.col index
385				#   (every 2rd item in the array).
386				my @spanArray = map $_ % 2 ? '0,0' : "$spanRow,".$spans->[$_], (0..($spanSize-1));
387				$self->spans(@spanArray);
388			}
389
390		}else{
391			warn("Spans array for row $row, is not a multiple of 2\n");
392		}
393
394	}
395
396
397	#    change state to normal if not already so we can modify the table
398	my $currentState = $self->cget(-state);
399	$self->configure(-state => 'normal') unless( $currentState eq 'normal');
400
401	# Move Any existing spans that are at rows > $row+$noRows to where the should be, now that rows
402	#  have been deleted
403	$self->adjustSpans($row+$noRows,-$noRows);
404
405	# deleteRows:
406	$self->deleteRows($row+1,$noRows);
407
408	my %indRowColsNew;
409	foreach my $rcindex(keys %$indRowCols){
410
411		my ($rowIndex,$colIndex) = split(',',$rcindex);
412		if($rowIndex > $row){ # adjust rows greater than the current row
413			my $newRow = $rowIndex-$noRows;
414			$indRowColsNew{"$newRow,$colIndex"} = $indRowCols->{$rcindex};
415		}
416		else{
417			$indRowColsNew{$rcindex} = $indRowCols->{$rcindex};
418		}
419	}
420	# Copy new to existing:
421	%$indRowCols = %indRowColsNew;
422
423
424	$noRows += $lowerLevelHideRows; # Include the lower level detail rows hidden in the internall array update
425
426
427	# Now Update the internal arrays for the deleted rows ###
428	my %expandDataNew;
429	foreach my $rowIndex(keys %$expandData){
430		if($rowIndex > ($row+$noRows)){ # adjust rows greater than the current row + detail data
431			$expandDataNew{$rowIndex-$noRows} = $expandData->{$rowIndex};
432		}
433		elsif($rowIndex<= $row){ # rows less than or equal just get copied
434			$expandDataNew{$rowIndex} = $expandData->{$rowIndex};
435		}
436		#else nothing, expand data that is in the detail data that is being hidden doesn't get copied
437	}
438	# Copy new to existing:
439	%$expandData = %expandDataNew;
440
441
442	# Put the state back
443	$self->configure(-state => $currentState) unless( $currentState eq 'normal');
444
445
446	return $noRows;
447
448
449}
450
451#----------------------------------------------
452# Sub called when -expandData option changes
453#
454sub expandData{
455	my ($self, $expandData) = @_;
456
457
458
459	if(! defined($expandData)){ # Handle case where $widget->cget(-expandData) is called
460
461		return $self->{Configure}{-expandData}
462
463	}
464
465	$self->clearSelectors;
466
467	my $selectorCol = $self->cget(-selectorCol);
468
469	# Create internal copy of expand Data for us to mess with
470	my $expandData_int = {};
471	%$expandData_int = %$expandData;
472	$self->{'_expandData'} = $expandData_int;
473
474	# update the indRowCols quick lookup hash:
475	$self->updateIndRowCols($expandData, $selectorCol);
476
477	$self->setSelectors;
478
479
480}
481
482
483
484
485#----------------------------------------------
486# Sub called when -selectorCol option changes
487#
488sub selectorCol{
489	my ($self, $selectorCol) = @_;
490
491
492
493	if(! defined($selectorCol)){ # Handle case where $widget->cget(-selectorCol) is called
494		#
495		# Set default if not defined yet
496		my $selCol;
497		unless( defined($self->{Configure}{-selectorCol})){
498			$selCol = $self->{Configure}{-selectorCol} = 0;
499		}
500		else{
501			$selCol = $self->{Configure}{-selectorCol};
502		}
503
504		return $selCol;
505
506	}
507
508	###### Get Old Selector Col and undo Here ?????###
509	$self->clearSelectors;
510
511	my $expandData = $self->cget('-expandData');
512
513	# update the indRowCols quick lookup hash:
514	$self->updateIndRowCols($expandData, $selectorCol);
515
516	$self->setSelectors;
517
518}
519
520# Method used to clear the selectors defined in the current indRowCols hash
521sub setSelectors{
522	my $self = shift;
523
524	my $indRowCols = $self->{indRowCols};
525
526	my @pluses = grep $indRowCols->{$_} eq '+', keys %$indRowCols;
527	my @minuses = grep $indRowCols->{$_} eq '-', keys %$indRowCols;
528
529	$self->tagCell('plus', @pluses);
530	$self->tagCell('minus', @minuses);
531
532	my $selectorCol = $self->cget('-selectorCol');
533	my $selectorColWidth = $self->cget(-selectorColWidth)  || 2; # set to '2' (the default), incase this called before the defaults have been set
534	$self->colWidth($selectorCol, $selectorColWidth);
535
536}
537
538
539
540
541# Method used to clear the selectors defined in the current indRowCols hash
542sub clearSelectors{
543	my $self = shift;
544
545	my @indRowCols = keys %{$self->{indRowCols}};
546	if( @indRowCols){
547		$self->tagCell('', keys %{$self->{indRowCols}});
548
549		# Get selectorCol from first entry
550		my ($row,$col) = split(',',$indRowCols[0]);
551		$self->colWidth($col, 'default');
552	}
553
554}
555
556
557### Method to update indRowCols, based on the expandData and selectorCol
558sub updateIndRowCols{
559
560	my $self = shift;
561
562	my($expandData, $selectorCol) = @_;
563
564	my $indRowCols = {};
565
566	foreach (keys %$expandData){
567		$indRowCols->{"$_,$selectorCol"} = '+';
568	}
569
570	$self->{indRowCols} = $indRowCols;
571	return $indRowCols;
572
573}
574
575# General Motion routine. Calls cellEnter if the pointer has entered another
576#  cell.
577
578sub GeneralMotion{
579
580	my $self  = shift;
581	my $Ev = $self->XEvent;
582
583	my $rc = $self->index('@' . $Ev->x.",".$Ev->y);
584
585	$self->SUPER::GeneralMotion;
586
587	my ($row,$col) = split(',',$rc);
588
589	my @border = $self->border('mark',$Ev->x,$Ev->y);
590	if( scalar(@border) == 0 &&  (!($self->{lastrc}) || $rc ne $self->{lastrc})){ # call cellEnter if cell number has changed and we aren't on a border
591		$self->{lastrc} = $rc;
592		$self->cellEnter($row,$col);
593	}
594
595
596
597}
598
599# Method called with the pointer goes over a different cell
600#  Sets the cursor to a top-right arrow if over
601#  the selectorCol
602
603sub cellEnter{
604
605	my $self  = shift;
606	my ($row,$col) = @_;
607
608	#print "Entered '$row,$col'\n";
609
610
611	my $rowColResizeDrag = $self->{rowColResizeDrag};  # Flag = 1 if cursor has been changed for a row/col resize
612
613	unless($rowColResizeDrag){
614
615		my $indRowCols = $self->{indRowCols};
616
617		if( defined( $indRowCols->{"$row,$col"})){
618			#print "Setting ind cursor\n";
619			$self->configure(-cursor => 'top_left_arrow');
620		}
621		else{
622			#print "Setting old cursor back '".$self->{normalCursor}."'\n";
623			$self->configure(-cursor => $self->{normalCursor});
624		}
625	}
626
627
628}
629
630
631#############################################################
632## Over-ridden beginselect. Epands cell if +/- cell selected
633sub BeginSelect{
634	my $self  = shift;
635	my $rc = shift;
636
637	my $indRowCols = $self->{indRowCols}; # get quick lookup hash
638	my $state;
639	if( defined($indRowCols->{$rc})) {
640		$state = $indRowCols->{$rc};
641		my ($row,$col) = split(',',$rc);
642		if( $state eq '-'){
643			$self->hideDetail($row, $self->{'_expandData'});
644		}
645		else{
646			$self->showDetail($row);
647		}
648
649		return;
650	}
651
652	# print "Calling inherited BeginSelect\n";
653	$self->SUPER::BeginSelect($rc);
654
655}
656
657
658#-------------------
659#  Method Called to adjust spans starting at  $row by $noRows
660#
661#   If noRows is greater than 0 then the spans are adjusted up by $noRows
662#   If noRows is negative, then spans are adjusted down by $noRows
663#
664#  This method is needed becase the rowinsert/delete methods of TableMatrix don't
665#  automatically adjust the spans
666sub adjustSpans{
667
668	my $self = shift;
669	my ($row,$noRows) = @_;
670
671	my %spans = $self->spans; # Get All Spans
672	my %spansFilterd; # filtered for row > $row
673	my $minRowFiltered = $row;
674	my @filteredIndexes = grep  { my ($r,$c) = split(',',$_); $r >= $minRowFiltered}    keys %spans;
675	my %unapplySpans; # temp hash used to unapply spans:
676	@unapplySpans{@filteredIndexes} = map '0,0', @filteredIndexes;
677	$self->spans(%unapplySpans);  # unapply the spans the filtered spans:
678	my %adjustedSpans;
679	foreach (@filteredIndexes){
680		my ($r,$c) = split(',',$_);
681		$adjustedSpans{($r+$noRows).",$c"} = $spans{$_};
682	}
683
684	# Apply adjusted Spans:
685	$self->spans(%adjustedSpans);
686
687}
688
6891;
690
691