libtk-tablematrix-perl 1.23-6build1 / usr / lib / perl5 / Tk / TableMatrix / SpreadsheetHideRows.pm

=head1 NAME

Tk::TableMatrix::SpreadsheetHideRows - Table Display with selectable hide/un-hide of rows

=head1 SYNOPSIS

  use Tk;
  use Tk::TableMatrix::SpreadsheetHideRows



  my $t = $top->Scrolled('SpreadsheetHideRows', 
  			      -selectorCol => 3,
			      -expandData => $hashRef,
			      -rows => 21, -cols => 11, 
                              -width => 6, -height => 6,
			      -titlerows => 1, -titlecols => 1,
			      -variable => $arrayVar,
			      -selectmode => 'extended',
			      -resizeborders => 'both',
			      -titlerows => 1,
			      -titlecols => 1,
			      -bg => 'white',
                    );

=head1 DESCRIPTION

L<Tk::TableMatrix::SpreadsheetHideRows> is a L<Tk::TableMatrix::Spreadsheet>-derived widget that implements
a Spreadsheet-like display of tabular information, where some of the rows in the table
can be expanded/hidden by clicking a '+/-' selector in the row. This can be used to display
top-level information in a table, while allowing the user to expand certain table rows to 
view detail-level information. 

See demos/SpreadsheetHideRows in the source distribution for a simple example of this widget

=head1 Widget-specific Options 

In addition the standard L<Tk::TableMatrix> widget options. The following options are implemented:

=over 1

=item  -selectorCol

Column number where the +/- selector will appear. Clicking on the +/- selector
will expand/hide the detail information in the table for a particular row.

=item  -selectorColWidth

Width of the column used to display the +/- selector. Defaults to 2

=item -expandData

Hash ref defining the detail-level data displayed when a row is expanded (by clicking
the +/- selector). This hash ref should have the following structure:

  $expandData = {  
  	row1 => {  tag  => 'detailDataTag',
	           data => $detailData,
		   spans=> $spanData,
		   expandData => $subLevelData
		},
	row2 => { 
	   .
	   .
  }
  
  Where: 
    row1, row2, ... 	    Row numbers that will be expandable.
    tag => 'detailDataTag'  Tag name that will be applied to the detail data.
    			    (optional)
    $detailData              2D Array of detail-data to be displayed when 
    			     the row is expanded.
			     e.g. [ [ r1c1, r1c2, r1c3 ],
			            [ r2c1, r2c2, r2,c3] ]
    $spans                   1D array of span information (optional) to be 
    			     used for display of the detail information.
			     e.g.  [ col2 =>  "rows,cols", col4 =>  "rows,cols", ... ]

    $subLevelData            Optional Recursive expandData used to hold detail-data of detail-data.



=back

=head1 MEMBER DATA

The following items are stored as member data

=over 1

=item defaultCursor

Name of the mouse cursor pointer that is used for normal (i.e. non-title, non-indicator) cells in the widget. 
This is set to the value of the $widget->cget(-cursor) option when the widget is created. 

=item indRowCols

Hash ref of Row/Cols indexes where there are indicators stores. This is a quick
lookup hash built from I<_expandData>.

=item _expandData

Internal version of the I<expandData> hash. Any sub-detail data (i.e. expand data 
that is at lower levels of I<expandData>) that is visible is placed at the top level of this hash, for
keeping track of the visible I<expandData>.

=back

=head1 Widget Methods 

In addition the standard L<Tk::TableMatrix> widget method. The following methods are implemented:


=cut

package Tk::TableMatrix::SpreadsheetHideRows;

use Carp;


use Tk;
use Tk::TableMatrix::Spreadsheet;
use Tk::Derived;

use base qw/ Tk::Derived Tk::TableMatrix::Spreadsheet/;

$VERSION = '1.23';


Tk::Widget->Construct("SpreadsheetHideRows");


sub ClassInit{
	my ($class,$mw) = @_;

	$class->SUPER::ClassInit($mw);
	
	

};


sub Populate {
    my ($self, $args) = @_;
    
    $self->ConfigSpecs(
       -selectorCol     => 	[qw/METHOD selectorCol     SelectorCol/,    undef],
       -selectorColWidth=> 	[qw/PASSIVE selectorColWidth     SelectorColWidth/,    2],
       -expandData      => 	[qw/METHOD expandData     ExpandData/,    {}],
   );

    
    $self->SUPER::Populate($args);
    
    $self->tagConfigure('plus', -image =>  $self->Getimage("plus"), -showtext => 0, -anchor => 'center');
    $self->tagConfigure('minus', -image =>  $self->Getimage("minus"), -showtext => 0,  -anchor => 'center');
    
    $self->{normalCursor} = $self->cget('-cursor'); # get the default cursor
 
 
}

=head2 showDetail

Shows (i.e. expands the table) the detail data for a given row. This method is called
when a user clicks on an indicator that is not already expanded.

B<Usage:>

 $widget->showDetail($row);  
 
 # Shows the detail data for row number $row

=cut

sub showDetail{

	my $self = shift;
	
	my $row = shift;
	
	my $selectorCol = $self->cget(-selectorCol);
	
	my $index = "$row,$selectorCol"; # make index for the cell to be expanded
	
	my $indRowCols = $self->{indRowCols};
	
	$self->tagCell('minus', $index);
	$indRowCols->{$index} = '-';
	
	# Get the detail data and insert:
	my $expandData = $self->{'_expandData'};
	my $detailData = $expandData->{$row};
	my $detailArray = $detailData->{data};
	
	my $noRows = scalar( @$detailArray);
	
	# InsertRows:
	#    change state to normal if not already so we can insert
	my $currentState = $self->cget(-state); 
	$self->configure(-state => 'normal') unless( $currentState eq 'normal');
	$self->insertRows($row,$noRows);
	
	# Adjust Spans:
	$self->adjustSpans($row+1,$noRows);
	
	#insert data
	my $colorigin =  $self->cget(-colorigin);
	my $rowNum = $row+1;
	foreach my $rowData( @$detailArray ){
		#my @rowArray = @$rowData; 
		#grep s/([\{\}])/\\$1/g, @rowArray; # backslash any existing '{' chars, so they don't get interpreted as field chars
		my $insertData = "{".join("}{", @$rowData)."}"; # make insert data look like tcl array, so it
								# gets put in different cells
		$self->set('row', "$rowNum,$colorigin", $insertData);
		$rowNum++;
	}
	
	# Apply Tags, if any:
	my $tag;
	if( defined( $detailData->{tag})){
		$tag = $detailData->{tag};
		my $startRow = $row+1;
		my $noRows = @$detailArray;
		my $stopRow = scalar(@$detailArray) + $startRow - 1;
		my @tagRows = ($startRow..$stopRow);
		$self->tagRow($tag,@tagRows);
	}

	# Apply Spans, if any:
	my $spans;
	if( defined( $detailData->{spans})){
		$spans = $detailData->{spans};
		
		my $spanSize = scalar(@$spans);
		#Error Checking, spans array should be a multiple of 2
		if( ($spanSize % 2) < 1){
		
			my $startRow = $row+1;
			my $noRows = @$detailArray;
			my $stopRow = scalar(@$detailArray) + $startRow - 1;
			foreach my $spanRow($startRow..$stopRow){
				# build an array to feed to spans, change column number for row.col index
				#   (every 2rd item in the array).
				my @spanArray = map $_ % 2 ? $spans->[$_] : "$spanRow,".$spans->[$_], (0..($spanSize-1));
				$self->spans(@spanArray);
			}
			
		}else{
			warn("Spans array for row $row, is not a multiple of 2\n");
		}
			
	}

	
	
	
	# Now Update the internal arrays for the inserted rows ###
	my %expandDataNew;
	foreach my $rowIndex(keys %$expandData){
		if($rowIndex > $row){ # adjust rows greater than the current row
			$expandDataNew{$rowIndex+$noRows} = $expandData->{$rowIndex};
		}
		else{
			$expandDataNew{$rowIndex} = $expandData->{$rowIndex};
		}
	}
	# Copy new to existing:
	%$expandData = %expandDataNew;
	
	
	my %indRowColsNew;
	foreach my $rcindex(keys %$indRowCols){
		
		my ($rowIndex,$colIndex) = split(',',$rcindex);
		if($rowIndex > $row){ # adjust rows greater than the current row
			my $newRow = $rowIndex+$noRows;
			$indRowColsNew{"$newRow,$colIndex"} = $indRowCols->{$rcindex};
		}
		else{
			$indRowColsNew{$rcindex} = $indRowCols->{$rcindex};
		}
	}
	# Copy new to existing:
	%$indRowCols = %indRowColsNew;
	
	# Take care of any lower-level detail data:
	my $subDetail;
	if( defined( $detailData->{expandData})){
		$subDetail = $detailData->{expandData};
		
		foreach my $subRow( keys %$subDetail){
			
			my $realRow = $row+$subRow;
			my $index = "$realRow,$selectorCol";
			$self->tagCell('plus', $index);
			$indRowCols->{$index} = '+'; # update internal array
			
			# put subdetail data to top level, adjusting the relative row
			# numbers to real row numbers:
			#my %adjustedSubDetail;
			#foreach my $subKey(keys %$subDetail){
			#	$adjustedSubDetail{$subKey+$row} = $subDetail->{$subKey};
			#}
			$expandData->{$realRow} = $subDetail->{$subRow}; 
		}

	}

	# Put the state back
	$self->configure(-state => $currentState) unless( $currentState eq 'normal');
	
	
}

=head2 hideDetail

Hides the detail data for a given row. This method is called
when a user clicks on an indicator that is already expanded.

B<Usage:>

 $widget->hideDetail($row);  
 
 # Hides the detail data for row number $row

=cut

sub hideDetail{

	my $self = shift;
	
	my $row = shift;
	my $expandData = shift;
	my $detailData = $expandData->{$row};

	my $selectorCol = $self->cget(-selectorCol);
	
	my $index = "$row,$selectorCol"; # make index for the cell to be hidden
	
	my $indRowCols = $self->{indRowCols};

	# hide any sublevel data first:
	my $lowerLevelHideRows = 0;
	if( defined( $detailData->{expandData})){ # sublevel data exists
		my $subLevelData = $detailData->{expandData};
		# convert sublevel data to absolute rows
		my $convertedSubData = {};
		foreach my $rowNum(keys %$subLevelData){
			$convertedSubData->{$rowNum+$row} = $subLevelData->{$rowNum};
		}
		#Hide lower level data, if showing
		my $subLevelIndex;
		foreach my $rowNum (sort {$a<=>$b} keys %$convertedSubData){
			$subLevelIndex = "$rowNum,$selectorCol";
			if( $indRowCols->{$subLevelIndex} eq '-'){
				# For lower-level hide-detail calls, we don't use any updates to the
				#   expandData Arg, so we create an anonymous hash ref in this call
				$lowerLevelHideRows += $self->hideDetail($rowNum,{ %$convertedSubData} );
			}
		}
	}
				
	
	$self->tagCell('plus', $index);
	$indRowCols->{$index} = '+';
	
	
	# Get the detail data and hide:
	my $detailArray = $detailData->{data};
	
	my $noRows = scalar( @$detailArray);

	# unapply any spans (This is not auto-handled by the row delete command, so we
	#  have to do it here manually)
	my $spans;
	if( defined( $detailData->{spans})){
		$spans = $detailData->{spans};
		
		my $spanSize = scalar(@$spans);
		#Error Checking, spans array should be a multiple of 2
		if( ($spanSize % 2) < 1){
		
			my $startRow = $row+1;
			my $noRows = @$detailArray;
			my $stopRow = scalar(@$detailArray) + $startRow - 1;
			foreach my $spanRow($startRow..$stopRow){
				# build an array to feed to spans, change column number for row.col index
				#   (every 2rd item in the array).
				my @spanArray = map $_ % 2 ? '0,0' : "$spanRow,".$spans->[$_], (0..($spanSize-1));
				$self->spans(@spanArray);
			}
			
		}else{
			warn("Spans array for row $row, is not a multiple of 2\n");
		}
			
	}


	#    change state to normal if not already so we can modify the table
	my $currentState = $self->cget(-state); 
	$self->configure(-state => 'normal') unless( $currentState eq 'normal');

	# Move Any existing spans that are at rows > $row+$noRows to where the should be, now that rows
	#  have been deleted
	$self->adjustSpans($row+$noRows,-$noRows);

	# deleteRows:
	$self->deleteRows($row+1,$noRows);

	my %indRowColsNew;
	foreach my $rcindex(keys %$indRowCols){
		
		my ($rowIndex,$colIndex) = split(',',$rcindex);
		if($rowIndex > $row){ # adjust rows greater than the current row
			my $newRow = $rowIndex-$noRows;
			$indRowColsNew{"$newRow,$colIndex"} = $indRowCols->{$rcindex};
		}
		else{
			$indRowColsNew{$rcindex} = $indRowCols->{$rcindex};
		}
	}
	# Copy new to existing:
	%$indRowCols = %indRowColsNew;	
	
	
	$noRows += $lowerLevelHideRows; # Include the lower level detail rows hidden in the internall array update


	# Now Update the internal arrays for the deleted rows ###
	my %expandDataNew;
	foreach my $rowIndex(keys %$expandData){
		if($rowIndex > ($row+$noRows)){ # adjust rows greater than the current row + detail data
			$expandDataNew{$rowIndex-$noRows} = $expandData->{$rowIndex};
		}
		elsif($rowIndex<= $row){ # rows less than or equal just get copied
			$expandDataNew{$rowIndex} = $expandData->{$rowIndex};
		}
		#else nothing, expand data that is in the detail data that is being hidden doesn't get copied
	}
	# Copy new to existing:
	%$expandData = %expandDataNew;
		

	# Put the state back
	$self->configure(-state => $currentState) unless( $currentState eq 'normal');


	return $noRows;


}

#----------------------------------------------
# Sub called when -expandData option changes
#
sub expandData{
	my ($self, $expandData) = @_;



	if(! defined($expandData)){ # Handle case where $widget->cget(-expandData) is called

		return $self->{Configure}{-expandData}
				
	}

	$self->clearSelectors;

	my $selectorCol = $self->cget(-selectorCol);
	
	# Create internal copy of expand Data for us to mess with
	my $expandData_int = {};
	%$expandData_int = %$expandData;
	$self->{'_expandData'} = $expandData_int;
	
	# update the indRowCols quick lookup hash:
	$self->updateIndRowCols($expandData, $selectorCol);
	
	$self->setSelectors;

	
}




#----------------------------------------------
# Sub called when -selectorCol option changes
#
sub selectorCol{
	my ($self, $selectorCol) = @_;



	if(! defined($selectorCol)){ # Handle case where $widget->cget(-selectorCol) is called
		#
		# Set default if not defined yet
		my $selCol;
		unless( defined($self->{Configure}{-selectorCol})){
			$selCol = $self->{Configure}{-selectorCol} = 0;
		}
		else{
			$selCol = $self->{Configure}{-selectorCol};
		}
		
		return $selCol;
				
	}

	###### Get Old Selector Col and undo Here ?????###
	$self->clearSelectors;
	
	my $expandData = $self->cget('-expandData');
	
	# update the indRowCols quick lookup hash:
	$self->updateIndRowCols($expandData, $selectorCol);
	
	$self->setSelectors;
	
}

# Method used to clear the selectors defined in the current indRowCols hash
sub setSelectors{
	my $self = shift;
	
	my $indRowCols = $self->{indRowCols};
	
	my @pluses = grep $indRowCols->{$_} eq '+', keys %$indRowCols;
	my @minuses = grep $indRowCols->{$_} eq '-', keys %$indRowCols;
	
	$self->tagCell('plus', @pluses);
	$self->tagCell('minus', @minuses);
	
	my $selectorCol = $self->cget('-selectorCol');
	my $selectorColWidth = $self->cget(-selectorColWidth)  || 2; # set to '2' (the default), incase this called before the defaults have been set
	$self->colWidth($selectorCol, $selectorColWidth);
	
}




# Method used to clear the selectors defined in the current indRowCols hash
sub clearSelectors{
	my $self = shift;
	
	my @indRowCols = keys %{$self->{indRowCols}};
	if( @indRowCols){
		$self->tagCell('', keys %{$self->{indRowCols}});
		
		# Get selectorCol from first entry
		my ($row,$col) = split(',',$indRowCols[0]);
		$self->colWidth($col, 'default');
	}
	
}
		

### Method to update indRowCols, based on the expandData and selectorCol
sub updateIndRowCols{

	my $self = shift;
	
	my($expandData, $selectorCol) = @_;
	
	my $indRowCols = {};
	
	foreach (keys %$expandData){
		$indRowCols->{"$_,$selectorCol"} = '+';
	}
	
	$self->{indRowCols} = $indRowCols;
	return $indRowCols;
	
}
	
# General Motion routine. Calls cellEnter if the pointer has entered another
#  cell.

sub GeneralMotion{

	my $self  = shift;
	my $Ev = $self->XEvent;

	my $rc = $self->index('@' . $Ev->x.",".$Ev->y);

	$self->SUPER::GeneralMotion;
	
	my ($row,$col) = split(',',$rc);

	my @border = $self->border('mark',$Ev->x,$Ev->y);
	if( scalar(@border) == 0 &&  (!($self->{lastrc}) || $rc ne $self->{lastrc})){ # call cellEnter if cell number has changed and we aren't on a border
		$self->{lastrc} = $rc;
		$self->cellEnter($row,$col);
	}
	

		
}

# Method called with the pointer goes over a different cell
#  Sets the cursor to a top-right arrow if over
#  the selectorCol

sub cellEnter{

	my $self  = shift;
	my ($row,$col) = @_;

	#print "Entered '$row,$col'\n";
	
	
	my $rowColResizeDrag = $self->{rowColResizeDrag};  # Flag = 1 if cursor has been changed for a row/col resize
	
	unless($rowColResizeDrag){
	
		my $indRowCols = $self->{indRowCols};
		
		if( defined( $indRowCols->{"$row,$col"})){ 
			#print "Setting ind cursor\n";
			$self->configure(-cursor => 'top_left_arrow');
		}
		else{
			#print "Setting old cursor back '".$self->{normalCursor}."'\n";
			$self->configure(-cursor => $self->{normalCursor});
		}
	}

		
}

		
#############################################################
## Over-ridden beginselect. Epands cell if +/- cell selected
sub BeginSelect{
	my $self  = shift;
	my $rc = shift;
	
	my $indRowCols = $self->{indRowCols}; # get quick lookup hash
	my $state;
	if( defined($indRowCols->{$rc})) {
		$state = $indRowCols->{$rc};
		my ($row,$col) = split(',',$rc);
		if( $state eq '-'){
			$self->hideDetail($row, $self->{'_expandData'});
		}
		else{
			$self->showDetail($row);
		}

		return;
	}
	
	# print "Calling inherited BeginSelect\n";
	$self->SUPER::BeginSelect($rc);
	
}


#------------------- 
#  Method Called to adjust spans starting at  $row by $noRows
#
#   If noRows is greater than 0 then the spans are adjusted up by $noRows
#   If noRows is negative, then spans are adjusted down by $noRows
#
#  This method is needed becase the rowinsert/delete methods of TableMatrix don't
#  automatically adjust the spans 
sub adjustSpans{
	
	my $self = shift;
	my ($row,$noRows) = @_;
	
	my %spans = $self->spans; # Get All Spans
	my %spansFilterd; # filtered for row > $row
	my $minRowFiltered = $row;
	my @filteredIndexes = grep  { my ($r,$c) = split(',',$_); $r >= $minRowFiltered}    keys %spans;
	my %unapplySpans; # temp hash used to unapply spans:
	@unapplySpans{@filteredIndexes} = map '0,0', @filteredIndexes;
	$self->spans(%unapplySpans);  # unapply the spans the filtered spans:
	my %adjustedSpans;
	foreach (@filteredIndexes){
		my ($r,$c) = split(',',$_);
		$adjustedSpans{($r+$noRows).",$c"} = $spans{$_};
	}
	
	# Apply adjusted Spans:
	$self->spans(%adjustedSpans);
	
}

1;